Loop Syntax Issues - vba

I am coding a series of loops to search one table row by row for data, and if it meets the correct specs within that row it will pull a certain value from said row and place it in a cell I want in a separate table on another chart. I am getting the error saying that there is a "Next" without a "For", but there is (unless I am entirely missing something). It also has the Sub line at the top highlighted (I am trying to run this as a macro). Let me know where I am going wrong here, thanks!
Option Explicit
Sub GraphLoop()
Dim i, g, row, color, roundcount, round, materialcount, material As Long
Dim chartdatacol, chartdatarow As Long
Worksheets("Chart Data").Range("C6:DR10000").Value = ""
roundcount = 1
materialcount = 1
color = 1
round = 1
material = 1
chartdatacol = 3
chartdatarow = 6
i = 4
For chartdatacol = 3 To Worksheets("Running Avg Log").Cells(4, cols.Count).End(xlUp).row
Do Until i = Worksheets("Running Avg Log").Cells(Rows.Count, "A").End(xlUp).row
g = 1
If Worksheets("Running Avg Log").Cells(i, 1).Value = Worksheets("Chart Data").Cells(chartdatarow, 2).Value _
And Worksheets("Running Avg Log").Cells(i, 2).Value = round _
And Worksheets("Running Avg Log").Cells(i, 3).Value = color _
And Worksheets("Running Avg Log").Cells(i, 4).Value = material Then
row = chartdatarow
Worksheets("Chart Data").Cells(row, chartdatacol).Value = _
Worksheets("Running Avg Log").Cells(i, 6 + Worksheets("Analysis").Range("C5").Value).Value
chartdatarow = chartdatarow + 1
i = 4
Else
i = i + 1
End If
Loop
color = color + 1
' loops through ten colors
If color > 10 Then
color = 1
End If
roundcount = roundcount + 1
materialcount = materialcount + 1
' every ten columns, material changes, every 30 columns, it repeats
If materialcount = 11 Or 21 Then
material = material + 1
End If
If materialcount > 30 Then
materialcount = 1
material = 1
' each round's 30 combos is 30 columns
If roundcount = 31 Then
round = round + 1
End If
Next chartdatacol
End Sub

You left out an End If here:
If materialcount > 30 Then
materialcount = 1
material = 1
' each round's 30 combos is 30 columns
BTW, another correction to make:
If materialcount = 11 Or 21 Then
should be:
If materialcount = 11 Or materialcount = 21 Then

You had an If without End If
See modified code below , I marked with ********* the place you were missing the End If :
Option Explicit
Dim i, g, row, color, roundcount, round, materialcount, material As Long
Dim chartdatacol, chartdatarow As Long
Sub GraphLoop()
Worksheets("Chart Data").Range("C6:DR10000").Value = ""
roundcount = 1
materialcount = 1
color = 1
round = 1
material = 1
chartdatacol = 3
chartdatarow = 6
i = 4
For chartdatacol = 3 To Worksheets("Running Avg Log").Cells(4, Columns.Count).End(xlUp).row
Do Until i = Worksheets("Running Avg Log").Cells(Rows.Count, "A").End(xlUp).row
g = 1
If Worksheets("Running Avg Log").Cells(i, 1).Value = Worksheets("Chart Data").Cells(chartdatarow, 2).Value _
And Worksheets("Running Avg Log").Cells(i, 2).Value = round _
And Worksheets("Running Avg Log").Cells(i, 3).Value = color _
And Worksheets("Running Avg Log").Cells(i, 4).Value = material Then
row = chartdatarow
Worksheets("Chart Data").Cells(row, chartdatacol).Value = _
Worksheets("Running Avg Log").Cells(i, 6 + Worksheets("Analysis").Range("C5").Value).Value
chartdatarow = chartdatarow + 1
i = 4
Else
i = i + 1
End If
Loop
color = color + 1
' loops through ten colors
If color > 10 Then
color = 1
End If
roundcount = roundcount + 1
materialcount = materialcount + 1
' every ten columns, material changes, every 30 columns, it repeats
If materialcount = 11 Or 21 Then
material = material + 1
End If
If materialcount > 30 Then
materialcount = 1
material = 1
' each round's 30 combos is 30 columns
If roundcount = 31 Then
round = round + 1
' **** YOU WERE MISSING the End If here ***
End If
End If
Next chartdatacol
End Sub

Related

VBA distribute values based on ranking

trying to finish a VBA that processes every 3 rows at a time.
using the order of the rank column, distribute the values accordingly to the next three rows without each cell exceeding the max value of 62 and prioritizing the highest rank.
sample data:
here's what i have so far:
max_value = 62
For irow = 2 To 80 Step 3
set_value = .Cells(irow, 2).Value
'if value less than max, then assign value to highest rank
If set_value < max_value Then
toprank_value = .Range(.Cells(irow, 1), .Cells(irow + 3, 1)).Find(what:="1", LookIn:=xlValues).Address
'assign value to rank of 1
toprank_value.Offset(0, 2).Value = set_value
GoTo NextIteration
'if not, distribute values across next 3 rows based on rank not going over max of 62
Else
'NEED HELP FOR CODE HERE
'NEED HELP FOR CODE HERE
End If
NextIteration:
Next
Thanks for any nudge to the right direction or if clarification is needed.
Assuming your value to distribute is always in the first of the 3 rows.
Its ugly but seems to work.
Sub distrib()
Set R1 = ActiveSheet.UsedRange 'Edit range if other data in sheet
T1 = R1
M = 62
For i = 2 To UBound(T1)
If T1(i, 2) > 0 Then
V = T1(i, 2)
If V <= M Then
For j = i To i + 2
If T1(j, 1) = 1 Then
T1(j, 3) = V
Else
T1(j, 3) = 0
End If
Next j
Else
A = M
V = V - M
If V > M Then
B = M
V = V - M
If V > M Then
C = M
Else
C = V
End If
Else
B = V
C = 0
End If
For j = i To i + 2
Select Case T1(j, 1)
Case Is = 1
T1(j, 3) = A
Case Is = 2
T1(j, 3) = B
Case Is = 3
T1(j, 3) = C
End Select
Next j
End If
End If
Next i
For i = 2 To UBound(T1)
Cells(i, 3) = T1(i, 3)
Next i
End Sub

VBA Excel - How to delete duplicate combinations

I wrote a code to write all the possible combinations with 3 numbers using a list of numbers.
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("AA3").Value
max = Range("AB3").Value
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("AA" & reference).Value = mppt1
Range("AB" & reference).Value = mppt2
Range("AC" & reference).Value = mppt3
referencia = reference + 1
Next mppt3
Next mppt2
Next mppt1
This works fine. But then, i need to delete all duplicate combinations (independent of the order)
For example, if i have this combinations:
16 | 17 | 18
16 | 18 | 17
18 | 17 | 17
18 | 16 | 16
After the delete, i should have this output:
16 | 17 | 18
18 | 17 | 17
18 | 16 | 16
How can i put this logic in my code?
Rather than getting rid of the duplicates, why not avoid avoid outputting them to start off with?
Instead of your second and third loops starting from min, have them start from the previous loop variable. Here's a similar working example I mocked up:
Sub Test()
Dim min As Integer, max As Integer
Dim i As Integer, j As Integer, k As Integer
min = 16
max = 18
For i = min To max
For j = i To max
For k = j To max
Debug.Print i, j, k
Next k
Next j
Next i
End Sub
this prints the following into the immediate window:
16 16 16
16 16 17
16 16 18
16 17 17
16 17 18
16 18 18
17 17 17
17 17 18
17 18 18
18 18 18
Try the code below. I added some code to add up the 3 cells and put the answer in column 5. Then I sort by column 5. The next loop uses the totals and deletes any total that is a duplicate each time the total changes.......
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("f1").Value
max = Range("g1").Value
reference = 1
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("A" & reference).Value = mppt1
Range("B" & reference).Value = mppt2
Range("C" & reference).Value = mppt3
reference = reference + 1
Next mppt3
Next mppt2
Next mppt1
Dim r As Integer
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("a1:a27") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:E27")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim Col1 As Integer
Dim Col2 As Integer
Dim Col3 As Integer
Col1 = Cells(1, 1)
Col2 = Cells(1, 2)
Col3 = Cells(1, 3)
r = 2
Do Until Len(Trim(Cells(r, 1))) = 0
DoEvents
startrow = r
Col1 = Cells(r, 1)
Col2 = Cells(r, 2)
Col3 = Cells(r, 3)
r = r + 1
Do While Cells(r, 1) = Col1
DoEvents
If Cells(r, 2) = Col2 And Cells(r, 3) = Col3 Then
Cells(r, 1).EntireRow.Delete
Else
If Cells(r, 2) = Col3 And Cells(r, 3) = Col2 Then
Cells(r, 1).EntireRow.Delete
Else
r = r + 1
End If
End If
Loop
r = startrow + 1
Loop
Cells(1, 5).EntireColumn.ClearContents
Use a dictionary to collect the unique sums as keys and the individual values as an array item then write the arrays back to the worksheet.
Option Explicit
Sub saqwjh()
Dim d As Long, k As Variant, dict As Object
Set dict = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
For d = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If Not dict.Exists(Application.Sum(.Rows(d))) Then
dict.Add Key:=Application.Sum(.Rows(d)), _
Item:=Array(.Cells(d, "A").Value2, _
.Cells(d, "B").Value2, _
.Cells(d, "C").Value2)
End If
Next d
For Each k In dict.Keys
.Cells(.Rows.Count, "E").End(xlUp).Resize(1, 3).Offset(1, 0) = dict.Item(k)
Next k
End With
End Sub

VBA - If two of three cells are true

I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If

How to loop through data in a table and add it to a Chart

The problem I am trying to solve using Excel VBA is with a table of information that I want to loop through and add to a Chart.
For example, the data file is in the following format:
-696.710022 48 0
0 415.853546 2 1
5 417.769196 2 1
10 419.684845 2 1
15 421.600464 2 1
20 423.516113 2 1
......
-602 48 0
0 371.893372 2 1
5 373.851685 2 1
10 375.810028 2 1
15 377.768372 2 1
20 379.726685 2 1
......
-497.76001 48 0
0 323.194183 2 1
5 325.189819 2 1
10 327.185486 2 1
15 329.181152 2 1
20 331.176819 2 1
......
etc.
In this file if Column 3 = "0" this is a header Row where by:
column 1 = location,
column 2 = number of points at location,
column 3 = header flag (i.e. "0")
The rest of the Rows are the data:
column 1 = X value,
column 2 = Y value,
column 3 = colour of points (i.e. 1 = green, 2 = blue, 3 = red).
I would like to run this in VBA because I have 40 or so of these charts to make. I have struggled making a script for VBA beyond importing a chart so I have not included my code here.
I really do appreciate any advice or suggestions on how to solve this.
Thank you :)
Assuming the value in the second column of a header row shows the number of rows until the next header row (the sample data has ... after a while), this will set up the data, insert the charts, and color the points.
Sub DoCharts()
Dim iRow As Long, nRows As Long, iPt As Long, nPts As Long
Dim rXVals As Range, rYVals As Range, rColor As Range
Dim cht As Chart
With ActiveSheet.UsedRange
For iRow = 1 To .Rows.Count
If .Cells(iRow, 3).Value = 0 And Len(.Cells(iRow, 3).Text) > 0 Then
' value is zero and cell is not blank
'define X and Y values
nPts = .Cells(iRow, 2).Value
Set rXVals = .Cells(iRow + 1, 1).Resize(nPts)
Set rYVals = rXVals.Offset(, 1)
Set rColor = rXVals.Offset(, 2)
' chart
Set cht = ActiveSheet.Shapes.AddChart(xlXYScatter, , .Cells(iRow, 1).Top).Chart
' clear existing series
Do While cht.SeriesCollection.Count > 0
cht.SeriesCollection(1).Delete
Loop
' add desired series
With cht.SeriesCollection.NewSeries
.Values = rYVals
.XValues = rXVals
End With
' point color
For iPt = 1 To nPts
With cht.SeriesCollection(1).Points(iPt)
Select Case rColor.Cells(iPt)
Case 1 ' green
.MarkerForegroundColor = vbGreen ' use nicer colors, of course
.MarkerBackgroundColor = vbGreen
Case 2 ' blue
.MarkerForegroundColor = vbBlue
.MarkerBackgroundColor = vbBlue
Case 3 ' red
.MarkerForegroundColor = vbRed
.MarkerBackgroundColor = vbRed
End Select
End With
Next
End If
cht.HasLegend = False
iRow = iRow + nPts
Next
End With
End Sub
EDIT - Plot all in same chart.
I made minor changes. I still used the individual X values from each block of data. But I assumed that an entire series would have the same color formatting, so I formatted by series and not by point. I formatted each series as lines with markers, instead of just markers. I also used the first cell in each header row as the series name, so these are what distinguish the series in the legend. Finally I did not reposition the chart, but let Excel place it in the default position.
Sub DoOneChart()
Dim iRow As Long, nRows As Long, iPt As Long, nPts As Long
Dim rXVals As Range, rYVals As Range, rName As Range
Dim iColor As Long
Dim cht As Chart
With ActiveSheet.UsedRange
For iRow = 1 To .Rows.Count
If .Cells(iRow, 3).Value = 0 And Len(.Cells(iRow, 3).Text) > 0 Then
' value is zero and cell is not blank
'define X and Y values
nPts = .Cells(iRow, 2).Value
Set rXVals = .Cells(iRow + 1, 1).Resize(nPts)
Set rYVals = rXVals.Offset(, 1)
iColor = .Cells(iRow + 1, 3).Value
Set rName = .Cells(iRow, 1)
' chart
If cht Is Nothing Then
Set cht = ActiveSheet.Shapes.AddChart(xlXYScatterLines).Chart
' clear existing series
Do While cht.SeriesCollection.Count > 0
cht.SeriesCollection(1).Delete
Loop
End If
' add desired series
With cht.SeriesCollection.NewSeries
.Values = rYVals
.XValues = rXVals
.Name = "=" & rName.Address(, , , True)
' series color
Select Case iColor
Case 1 ' green
.MarkerForegroundColor = vbGreen ' use nicer colors, of course
.MarkerBackgroundColor = vbGreen
.Border.Color = vbGreen
Case 2 ' blue
.MarkerForegroundColor = vbBlue
.MarkerBackgroundColor = vbBlue
.Border.Color = vbBlue
Case 3 ' red
.MarkerForegroundColor = vbRed
.MarkerBackgroundColor = vbRed
.Border.Color = vbRed
End Select
End With
End If
iRow = iRow + nPts
Next
cht.HasLegend = True
End With
End Sub

Excel Barcode Scanner Column Data to Row

I am using a barcode scanner to do inventory with large quantities and I want to enter the data into excel. I can change the way that the scanner behaves after each scan to do things like tab, return, etc. but my big problem is that in order to efficiently provide the quantity I have to scan the item code (7 digits) and then scan the quantities from 0 to 9 in succession. Such that 548 is really 5, 4, 8 and when using excel it puts each number into a new cell. What I would like to do, but don't have the VBA chops to do it is to have excel check to see if the length is 7 digits or one digit. For each one digit number it should move the number to the next cell in the same row as the previous 7 digit number such that each successive one digit number is combined as if excel were concatenating the cells. Then it should delete the single digits in the original column and have the next row start with the 7 digit barcode number.
I hope this makes sense.
Example:
7777777
3
4
5
7777778
4
5
6
7777779
7
8
9
Should become:
| 7777777 | 345 |
| 7777778 | 456 |
| 7777779 | 789 |
Thanks!!
I set up my worksheet like this:
then ran the below code
Sub Digits()
Application.ScreenUpdating = False
Dim i&, r As Range, j&
With Columns("B:B")
.ClearContents
.NumberFormat = "#"
End With
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
If Len(r) = 7 Then
j = 1
Do Until ((Len(r.Offset(j, 0).Text) = 7) Or (IsEmpty(r.Offset(j, 0))))
Cells(i, 2) = CStr(Cells(i, 2).Value) & CStr(r.Offset(j, 0))
j = j + 1
Loop
End If
Set r = Nothing
Next
For i = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
If Len(Cells(i, 1)) < 7 Then Rows(i & ":" & i).Delete
Next i
Columns.AutoFit
Application.ScreenUpdating = True
End Sub
and the results Ive got:
This is what I did with what you started but I think your newer solution will work better. Thank you so much mehow!
Sub Digits()
Application.ScreenUpdating = False
Dim i, arr, r As Range
Dim a, b, c, d, e
Dim y
For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
Set r = Cells(i, 1)
Set a = Cells(i + 1, 1)
Set b = Cells(i + 2, 1)
Set c = Cells(i + 3, 1)
Set d = Cells(i + 4, 1)
Set e = Cells(i + 5, 1)
If Len(a) = 7 Then
y = 0
ElseIf Len(b) = 7 Then
y = 1
ElseIf Len(c) = 7 Then
y = 2
ElseIf Len(d) = 7 Then
y = 3
ElseIf Len(e) = 7 Then
y = 4
Else:
y = 0
End If
If Len(r) = 7 Then
arr = Range("A" & i & ":A" & i + y).Value
Range("B" & i & ":F" & i) = WorksheetFunction.Transpose(arr)
End If
Next
Cells.Replace "#N/A", "", xlWhole
Application.ScreenUpdating = True
End Sub