I'm new to programming, and VBA, and seem to be a bit stuck with a piece of code I have written. I understand that I need to put in a next inbetween the two Fors on my code, I'm just not sure where and what should follow.
Please help!! Here's my code if anyone can help me!
Sub Order()
rowdata = 1
Do While Cells(rowdata, 1) <> ""
rowdata = rowdata + 1
Loop
dataend = rowdata - 1
rowwrite = rowdata + 2
Cells(rowwrite, 1) = "Item Code"
For col = 1 To 3
Cells(rowwrite, col) = Cells(1, col)
Next col
rowwrite = rowwrite + 1
target = Cells(2, 7)
**For** rowdata = 2 To dataend
If Cells(rowdata, 1) = target Then
Cells(rowdata, 5) = Cells(rowdata, 5) - 1
End If
If Cells(rowdata, 5) = Cells(rowdata, 4) Then
**For** col = 1 To 3
Cells(rowwrite, col) = Cells(rowdata, col)
Next col
rowwrite = rowwrite + 1
End If
End sub
Thanks in advance!
**For** rowdata = 2 To dataend
If Cells(rowdata, 1) = target Then
Cells(rowdata, 5) = Cells(rowdata, 5) - 1
End If
If Cells(rowdata, 5) = Cells(rowdata, 4) Then
**For** col = 1 To 3
Cells(rowwrite, col) = Cells(rowdata, col)
Next col
rowwrite = rowwrite + 1
End If
Next rowData
I've reformatted your indents to a more standard method. There are two places you can put your "Next" statement it just depends on the logic you need. I've put in in between loops but if you can nest the loops (one inside the other) if that is what you need logically.
Sub Order()
rowdata = 1
Do While Cells(rowdata, 1) <> ""
rowdata = rowdata + 1
Loop
dataend = rowdata - 1
rowwrite = rowdata + 2
Cells(rowwrite, 1) = "Item Code"
For col = 1 To 3
Cells(rowwrite, col) = Cells(1, col)
Next col
rowwrite = rowwrite + 1
target = Cells(2, 7)
For rowdata = 2 To dataend 'your ** line
If Cells(rowdata, 1) = target Then
Cells(rowdata, 5) = Cells(rowdata, 5) - 1
End If
Next 'new Next
If Cells(rowdata, 5) = Cells(rowdata, 4) Then
For col = 1 To 3
Cells(rowwrite, col) = Cells(rowdata, col)
Next col
rowwrite = rowwrite + 1
End If
End Sub
Related
I have a list of data displayed on a listbox, after clicking on a button the list appears on my userform.
I have dates on column 2 of my list, I want to do a descending sorting.
I have the code bellow but it's not working, am I wrong ?
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
fin_col_Form_Init = Ws.Cells(6, 256).End(xlToLeft).Column
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
For i = 2 To fin_col_Form_Init
UF_Profil_Edit1.ListBox_Form_Init.AddItem Ws.Cells(6, i)
UF_Profil_Edit1.ListBox_Form_Init.List(UF_Profil_Edit1.ListBox_Form_Init.ListCount - 1, 1) = Ws.Cells(7, i)
Next i
Dim y, x As Integer
Dim MyList As Variant
With UF_Profil_Edit1.ListBox_Form_Init
For y = 0 To .ListCount - 1
For x = y To .ListCount - 1
If CDate(.List(x, 1)) > CDate(.List(y, 1)) Then
For c = 0 To 2
MyList = .List(x, c)
.List(x, c) = .List(y, c)
.List(y, c) = MyList
Next c
End If
Next x
.List(y, 2) = Format(.List(y, 2), "####.00")
Next y
End With
Try the next code, please:
Sub testSortListBox()
Dim i As Long, j As Long, sTemp As Date, sTemp2 As String, SortList As Variant
UF_Profil_Edit1.ListBox_Form_Init.ColumnCount = 2
UF_Profil_Edit1.ListBox_Form_Init.ColumnWidths = "300;100"
'Store the list in an array to be sorted:
SortList = UF_Profil_Edit1.ListBox_Form_Init.List
'Sort the array on the second column
For i = LBound(SortList, 1) To UBound(SortList, 1) - 1
For j = i + 1 To UBound(SortList, 1)
If CDate(SortList(i, 1)) < CDate(SortList(j, 1)) Then
'Swap the second value
sTemp = SortList(i, 1)
SortList(i, 1) = SortList(j, 1)
SortList(j, 1) = sTemp
'Swap the first value
sTemp2 = SortList(i, 0)
SortList(i, 0) = SortList(j, 0)
SortList(j, 0) = sTemp2
End If
Next j
Next i
'Remove the contents of the listbox:
UF_Profil_Edit1.ListBox_Form_Init.Clear
'Load the sorted array in the list box:
UF_Profil_Edit1.ListBox_Form_Init.List = SortList
End Sub
But, please note: The list box in discussion must not be linked to a range (not being load by its RowSource property...
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
Hi I have created a workbook that uses formula to populate lists, one of which uses VBA to print labels.
My problem is the VBA sees the cell formula in blank cells and wants to print blank tags. How can I change it to see text only?
As I said, I need to edit my VBA to ignore formula and read only the resulting text.
VBA is below.
Sub Print_Labels()
Application.ScreenUpdating = False
Col_Width_1 = Range("Column_Width_1")
Col_Width_2 = Range("Column_Width_2")
Col_Width_3 = Range("Column_Width_3")
Col_Width_4 = Range("Column_Width_4")
Row_Height_1 = Range("Row_Height_1")
Row_Height_2 = Range("Row_Height_2")
Row_Height_3 = Range("Row_Height_3")
Row_Height_4 = Range("Row_Height_4")
Sheets("Equipment_List").Select
Num_Equip = Range("A1").CurrentRegion.Rows.Count
Start_Row = Range("Title_Label_Start_Row")
First_Page_YN = True
Names.Add "Equipment_List", "=" + Range("A1").Resize(Num_Equip).Address
Sheets("Labels").Select
' Set page setup
' Set column widths
For Count_Label_Columns = 1 To Num_Label_Columns
Range("A1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_1
Range("B1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_2
Range("C1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_3
Range("D1").Offset(, (Count_Label_Columns - 1) *
4).EntireColumn.ColumnWidth = Col_Width_4
Next Count_Label_Columns
' Set row heights
For Count_Label_Rows = 1 To Num_Label_Rows
Range("A1").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_1
Range("A2").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_2
Range("A3").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_3
Range("A4").Offset((Count_Label_Rows - 1) * 4).EntireRow.RowHeight =
Row_Height_4
Next Count_Label_Rows
' Work out the first label row to be printed
If Start_Row > 10 Then Start_Row = 10
Count_Label_Rows = Start_Row
' Labels always start printing in the first column
Count_Label_Columns = 0
For Count_Equip = 1 To Num_Equip
' Start of new page of labels, so completely clear sheet
If First_Page_YN = True Then
Cells.Clear
First_Page_YN = False
End If
Count_Label_Columns = Count_Label_Columns + 1
If Count_Label_Columns > Num_Label_Columns Then
Count_Label_Columns = 1
Count_Label_Rows = Count_Label_Rows + 1
End If
If Count_Label_Rows > Num_Label_Rows Then
Count_Label_Rows = 1
Count_Label_Columns = 0
End If
If Count_Label_Rows = 1 And Count_Label_Columns = 0 Then
' Start of new page, so print full sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Cells.Clear
Count_Label_Columns = 1
End If
Range("Title_Label_Format").Copy
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 1).PasteSpecial
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4) + 2,
((Count_Label_Columns - 1) * 4) + 2) = _
Range("Equipment_List").Offset(Count_Equip - 1).Resize(1, 1)
' Enter the sequence number of the equipment
Range("Labels_Top").Offset(((Count_Label_Rows - 1) * 4),
((Count_Label_Columns - 1) * 4) + 3) = Count_Equip
Next Count_Equip
' Print or Preview the last sheet
If Range("Title_Print_Preview") = "Print" Then
ActiveSheet.PrintOut
Else
ActiveSheet.PrintPreview
End If
Application.ScreenUpdating = True
End Sub
-------------------------------------------------------------------------------
I have an excel table where there are part codes in a column and for every part code, there are 3-4 subsections (1100-1400) with information which I need to attach to the part code in a column view.
The number of created rows depends on if there is data entered into subsection 1400. 1100-1300 has always information and needs to be converted into a table.
I don't even know from where to start so currently I have no code to show
I added a picture of how the data is represented and what the result should look like:
You could do it like that
Option Explicit
Sub TransformA()
Dim rg As Range
Dim lastRow As Long, lineNo As Long, i As Long, j As Long
Dim shInput As Worksheet, shResult As Worksheet
Dim vDat As Variant, resDat As Variant
Dim subSection As String
' Make sure you run the code with the data in the Activesheet
Set shInput = ActiveSheet
' And you have data which starts in row 4 with the heading in row 3
' otherwise adjust accordingly
lastRow = shInput.Range("A4").End(xlDown).Row
Set rg = shInput.Range("A4:I" & lastRow)
vDat = rg
ReDim resDat(1 To UBound(vDat, 1) * 4, 1 To 4)
lineNo = 1
For j = 1 To UBound(vDat, 1)
For i = 0 To 2
Select Case i
Case 0: subSection = "1100"
Case 1: subSection = "1200"
Case 2: subSection = "1300"
End Select
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
Next
i = 3
subSection = "1400"
If Len(vDat(j, 2 + 2 * i)) = 0 And Len(vDat(j, 3 + 2 * i)) = 0 Then
lineNo = lineNo + 3
Else
resDat(lineNo + i, 1) = vDat(j, 1)
resDat(lineNo + i, 2) = subSection
resDat(lineNo + i, 3) = vDat(j, 2 + 2 * i)
resDat(lineNo + i, 4) = vDat(j, 3 + 2 * i)
lineNo = lineNo + 4
End If
Next
' Output the result to a new sheet
Set shResult = Sheets.Add
With shResult
.Cells(1, 1).Value = "Part Code"
.Cells(1, 2).Value = "Subsection"
.Cells(1, 3).Value = "Time"
.Cells(1, 4).Value = "Text"
End With
shResult.Range("A2").Resize(UBound(resDat, 1), 4) = resDat
End Sub
Hello I have three columns with filled with names. So far I need to extract the three first cells of each column and put all the 15 names into a forth column. But if there are duplicates I must not put them in the list.
So far I got into
Private Sub CommandButton1_Click()
Dim temp(15) As String
Dim array1(5) As String
Dim array2(5) As String
Dim array3(5) As String
Dim i As Integer
Dim j As Integer
For i = 1 To 5
array1(i) = Cells(i + 3, 1).Value
array2(i) = Cells(i + 3, 4).Value
array3(i) = Cells(i + 3, 7).Value
Next i
temp(1) = array1(1)
temp(2) = array1(2)
temp(3) = array1(3)
temp(4) = array1(4)
temp(5) = array1(5)
temp(6) = array2(1)
temp(7) = array2(2)
temp(8) = array2(3)
temp(9) = array2(4)
temp(10) = array2(5)
temp(11) = array3(1)
temp(12) = array3(2)
temp(13) = array3(3)
temp(14) = array3(4)
temp(15) = array3(5)
For i = 1 To 15
For j = 1 To 15
If (temp(i) = temp(j + 1)) Then
Else
Cells(i + 4, 10).Value = temp(i)
End If
Next j
j = 0
Next i
End Sub
For i = 1 to 3
Cells(6 * i - 5, 10).Resize(5, 1).Value = Cells(6 * i - 5, 4 * i - 3).Resize(5,1).Value
Next
Application.DisplayAlerts = False
Cells(1, 10).Resize(15, 1).RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = True