I'm trying to create a loop that pulls in the value on the second image.
Image 1 -
Image 2 -
Here is how you could do it, with two embedded loops.
Sub CopyStates()
Dim StateRow%
Dim CopyRow%
Dim FruitRow%
Dim FruitMaxRow%
'these three constants define in which columns your data can be found
Const STATE_COL = 1
Const COPY_COL = 6
Const FRUIT_COL = 7
'these constant define the start row of your data
Const DATA_START_ROW_S = 3 'start row for states
Const DATA_START_ROW_P = 2 'start row for fruits and copy
FruitMaxRow = DATA_START_ROW_P
StateRow = DATA_START_ROW_S
'first, check how many fruits you have
While Cells(FruitMaxRow, FRUIT_COL) <> ""
FruitMaxRow = FruitMaxRow + 1
Wend
'initialize: begin copying at the first empty row where you had fruits
CopyRow = FruitMaxRow
'loop through all the states
While Cells(StateRow, STATE_COL) <> ""
'loop through all the fruits
For FruitRow = DATA_START_ROW_P To FruitMaxRow - 1
'copy the state and fruit
Cells(CopyRow, COPY_COL) = Cells(StateRow, STATE_COL)
Cells(CopyRow, FRUIT_COL) = Cells(FruitRow, FRUIT_COL)
CopyRow = CopyRow + 1
Next FruitRow
StateRow = StateRow + 1
Wend
End Sub
Related
I start using structured table with VBA code, but here I face a problem which I do not manage by myself.
I have a structured table in which I loop through 1 column and need to get values from other columns depending on some criteria:
if the cells value is "Finished"
then I take 3 dates (dateScheduled, dateRelease and dateReady) from 3 other columns and perform some calculations and tests based on these dates
the problem is that I can get the values of the date columns (they are well formatted and have values in it), so none of the next actions triggered by the first if is working.
Here is part of the whole code of my macro, I hope this is sufficient to figure out what is wrong.
For Each valCell In Range("thisIsMyTable[Task Status]").Cells
If valCell = "Finished" Then
dateScheduled = Range("thisIsMyTable[End Date]").Cells
dateRelease = Range("thisIsMyTable[Release Date]").Cells
dateReady = Range("thisIsMyTable[Date Ready]").Cells
totalFinishCat = totalFinishCat + 1
daysToFinished = daysToFinished + DateDiff("d", dateReady, dateRelease)
If Range("thisIsMyTable[Time Spent]").Cells = "" Then
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time estimate]").Cells + Range("thisIsMyTable[Extra hours]").Cells
Else
timeTotalFinished = timeTotalFinished + Range("thisIsMyTable[Time Spent]").Cells
End If
If dateRelease >= dateStartReport Then
monthFinished = monthFinished + 1
timeMonthFinished = timeMonthFinished + Range("thisIsMyTable[Time Spent]").Cells
daysToFinishedMonth = daysToFinishedMonth + DateDiff("d", dateReady, dateRelease)
If dateRelease > dateScheduled Then
afterDue = afterDue + 1
diff = DateDiff("d", dateScheduled, dateRelease)
afterDay = afterDay + diff
Else
beforeDue = beforeDue + 1
diff = DateDiff("d", dateRelease, dateScheduled)
beforeDay = beforeDay + diff
End If
End If
End If
Next valCell
I have tried out by adding .value or .value2 like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value
or
dateScheduled = Range("thisIsMyTable[End Date]").Cells.value2
but it does not work better. I have checked by adding .select like so:
dateScheduled = Range("thisIsMyTable[End Date]").Cells.select
and this will select the entire column, not the cells as I expect. So it appears that my method to just get the cells value is not appropriate.
Any help is welcome
If you create a lookup of column names to column number, you can loop through the rows of the table and extract the value using Range(1, columnno). For example
Option Explicit
Sub MyMacro()
Dim ws As Worksheet, tb As ListObject
Dim r As ListRow
Dim sStatus As String, dEnd As Date, dRelease As Date, dReady As Date
' table
Set ws = Sheet1
Set tb = ws.ListObjects("thisIsMyTable")
' lookup column name to number
Dim dict As Object, c As ListColumn
Set dict = CreateObject("Scripting.Dictionary")
For Each c In tb.ListColumns
dict.Add c.Name, c.Index
Next
' scan table rows
For Each r In tb.ListRows
sStatus = r.Range(1, dict("Task Status"))
If sStatus = "Finished" Then
dEnd = r.Range(1, dict("End Date"))
dRelease = r.Range(1, dict("Release Date"))
dReady = r.Range(1, dict("Date Ready"))
Debug.Print dEnd, dRelease, dReady
End If
Next
End Sub
I'm fairly new to Excel VBA and still learning the ropes, so I need help with a step by step program without using any functions. I understand how to count through an unknown column range and output the quantity. However, for this program, I'm trying to loop through a column, picking out unique numbers and counting its frequency.
So I have an excel file with random numbers down column A. I only put in 20 numbers but let's pretend the range is unknown. How would I go about extracting the unique numbers and inputting them into a separate column along with how many times they appeared in the list?
I have a code, but it's not working and I don't know why.
Public Sub CreateInventoryReport()
Dim bcode As Long
Dim ubcode As Long
'Below is the part that is not working
If Worksheets("Sheet 2").Range("A1")<>" Then
' First Value Is unique
Worksheets("Sheet2").Range("D5") = Worksheets("Sheet2").Range("A1")
Worksheets("Sheet2").Range("E5") = 1
Else
r = MsgBox("no data", , "no data")
Exit Sub
End If
bcode = 2
Do While Worksheets("Sheet 2").Cell(bcode, 1) <> ""
ubcode = 5
IsMatch = False
Do While Worksheets("Sheet 2").Cell(ubcode, 4) <> ""
If Worksheets("Sheet 2").Cell(bcode, 1) = Worksheets("Sheets2").Cell(ubcode, 4) Then
Worksheets("Sheet 2").Cell(ubcode, 5) = Worksheets("Sheet2").Cell(ubcode, 5) + 1
IsMatch = True
Exit Do
End If
ubcode = ubcode + 1
Loop
If IsMatch = False Then
Worksheets("Sheet2").Cell(ubcode, 4) = Worksheets("Sheet2").Cell(bcode, 1)
Worksheets("Sheet 2").Cell(ubcode, 5) = 1
End If
bcode = bcode + 1
Loop
End Sub
I have a table that has 4 columns:
ID
keyword
Component
NewComponent
The first 3 contain data and the last one does not.
I have the data sorted by keyword then by component.
Looking at the image below:
Original Table:
Expected Result:
So as far as I can see, two loops need to be done:
Loop through keyword
While looping through keyword, loop through components and create new ones
This is the code I have so far, but I have confused myself with all the loops already..
Sub SingleColumnTable_To_Array()
Dim myTable As ListObject
Dim myArray As Variant
Dim x As Long
Dim compArr() As String, kwArr(), newArr()
Set tmpltWkbk = Workbooks("New DB.xlsm")
Set ws1 = tmpltWkbk.Sheets("TableSheet")
Set myTable = ws1.ListObjects("KW_Table")
counterOne = 0
myArray = myTable.DataBodyRange
kwCounter = 1
'keywords
For y = LBound(myArray) To UBound(myArray)
counterTwo = counterTwo + 1
ReDim Preserve kwArr(counterTwo)
kwArr(counterTwo) = myArray(y, 23)
Next y
RemoveDupesDict kwArr, newArr
'components
For x = LBound(myArray) To UBound(myArray)
counterOne = counterOne + 1
ReDim Preserve compArr(counterOne)
compArr(counterOne) = myArray(x, 3)
Next x
For Each kwElement In newArr
For Each compElement In compArr
Counter = 1
Do While kwCounter < Application.CountIf(kwArr, kwElement) + 1
'This is how I imagine I would create the new component name
'Selection.Offset(0, 1).Value = compElement & "." & Counter
Counter = Counter + 1
kwCounter = kwCounter + 1
Loop
End If
Next compElement
Next kwElement
End Sub
As per comment above. Expanded code slightly to add a new column to a table and insert the formula in case you want a VBA solution:
Sub x()
Dim t As ListObject
Set t = Sheets(1).ListObjects("Table1")
t.ListColumns.Add
t.ListColumns(t.DataBodyRange.Columns.Count).DataBodyRange.Formula = "=C2&"".""&COUNTIFS($B$2:B2,B2,$C$2:C2,C2)"
End Sub
I’m using a userform with 12 listboxes (numbered 2-13). Each list box could contain 0-8 items assigned by user from main listbox1. I run the following code to output the content of each list box (12 boxes) to sheet “Tray” when a button is pressed.
Each listbox is then output into corresponding columns of each tray from columns B-M. Listbox2 fills column 1 of each tray and so on. A maximum of 4 trays can be filled. The code checks the 1st well of each tray and if it contains a value it assumes the tray is full & begins filling the next tray.
Problem: If the first tray contains a blank column(listbox) and the second tray contains values in the same listbox, the code will fill blank column of the frist tray with values that should be in the second tray. Please see pictures below and updated code below:
Listboxes 2,3 and 4 for Tray 1 (note listbox3 is empty)
Listboxes 2,3 and 4 for tray 2 (note listbox3 has data)
Code ran two times: Listbox3 from tray2 appears in tray1 (erroneously!!!)
Expected output:
Sub Worklist()
'
Dim Var, VarName As Variant
Dim i, DblDashPos, FirstPeriodPos, lngColNum, lngRowNum As Long
Dim item As ListBox
Const cstrNames As String = "Listbox2,Listbox3,Listbox4,Listbox5,Listbox6,Listbox7,Listbox8,Listbox9,Listbox10,Listbox11,Listbox12,Listbox13"
Application.ScreenUpdating = False
lngColNum = 2
For Each VarName In Split(cstrNames, ",")
If UserForm2.Controls(VarName).ListIndex <> -1 Then 'if listbox is not blank
If Sheets("Tray").Cells(4, lngColNum).Value = 0 Then
'checks if value in row 3 column "lngColNum" is empty
lngRowNum = 4
ThisWorkbook.Sheets("Tray").Range("C2").Value = UserForm2.TextBox1.Value
ElseIf Sheets("Tray").Cells(15, lngColNum).Value = 0 Then 'checks if value in row 14 column "lngColNum" is empty
lngRowNum = 15
ThisWorkbook.Sheets("Tray").Range("C13").Value = UserForm2.TextBox1.Value
ElseIf Sheets("Tray").Cells(26, lngColNum).Value = 0 Then 'checks if value in row 14 column "lngColNum" is empty
lngRowNum = 26
ThisWorkbook.Sheets("Tray").Range("C24").Value = UserForm2.TextBox1.Value
Else 'otherwise assumes tray starts in row 5, column "lngColNum"
lngRowNum = 37
ThisWorkbook.Sheets("Tray").Range("C35").Value = UserForm2.TextBox1.Value
End If
For i = 0 To UserForm2.Controls(VarName).ListCount - 1
Var = UserForm2.Controls(VarName).List(i)
DblDashPos = InStr(1, Var, "--")
FirstPeriodPos = InStr(1, Var, ".")
Sheets("Tray").Select
ActiveSheet.Cells(lngRowNum, lngColNum) = Left(Var, DblDashPos - 1) & Right(Var, Len(Var) - FirstPeriodPos + 1)
lngRowNum = lngRowNum + 1
Next i
End If
lngColNum = lngColNum + 1
Next
Application.ScreenUpdating = True
End Sub
Thank you very much!
The problem is that you're only testing the column that corresponds to the ListBox to see if the cell is empty. If you want to test that all of the columns in a "tray" are empty, you need to test once for the entire sheet. Something like this (untested because I'm too lazy to rebuild your form):
Private Function FindFirstUnusedRow(sheet As Worksheet) As Long
Dim testColumn As Long, testRow As Long
Dim used As Boolean
For testRow = 4 To 37 Step 11
used = False
For testColumn = 2 To 13
If IsEmpty(sheet.Cells(testRow, testColumn)) = False Then
used = True
Exit For
End If
Next testColumn
If used = False Then
FindFirstUnusedRow = testRow
Exit For
End If
Next testRow
End Function
Then in your code, call it before your loop:
Sub Worklist()
Dim var As Variant
Dim i As Long, dashPos As Long, periodPos As Long, colNum As Long
Dim rowNum As Long, Dim sheet As Worksheet
Application.ScreenUpdating = False
Set sheet = ThisWorkbook.Sheets("Tray")
rowNum = FindFirstUnusedRow(sheet)
If rowNum = 0 Then
Debug.Print "All trays full."
Exit Sub
End If
Dim current As ListBox
For colNum = 2 To 13
Set current = UserForm2.Controls("Listbox" & colNum)
If current.ListIndex <> -1 Then 'if listbox is not blank
sheet.Cells(rowNum - 2, colNum).Value = UserForm2.TextBox1.Value
For i = 0 To current.ListCount - 1
var = current.List(i)
dashPos = InStr(1, var, "--")
periodPos = InStr(1, var, ".")
sheet.Cells(rowNum + i, colNum) = Left$(var, dashPos - 1) & _
Right$(var, Len(var) - periodPos + 1)
Next i
End If
Next colNum
Application.ScreenUpdating = True
End Sub
A couple other notes: You can ditch the Sheets("Tray").Select line entirely - you never use the selection object. Same thing with the mixed references to ActiveSheet and ThisWorkbook.Sheets("Tray"). Grab a reference and use it.
Also, these lines don't do what you think they do:
Dim Var, VarName As Variant
Dim i, DblDashPos, FirstPeriodPos, lngColNum, lngRowNum As Long
Of all the variables you declare, everything is a Variant except lngRowNum. If you want to combine declarations on one line like that, you still need to specify a type for each variable, or they'll default to Variant. See the example code above.
I have a file with the below information
#Name Image Image Image
product 1 image111A.jpg image111B.jpg
product 2 image222A.jpg image222B.jpg image222C.jpg
product 3 image333A.jpg image333B.jpg
and would like to convert into like below in excel using macro or formula
#Name Image
product 1 image111A.jpg
product 1 image111B.jpg
product 2 image222A.jpg
product 2 image222B.jpg
product 2 image222C.jpg
product 3 image333A.jpg
product 3 image333B.jpg
Probably it should be something like the following. It can be done nicer, but then it would be harder to understand, I think.
Sub MakeItFlat()
Dim sourceSheet, targetSheet As Worksheet
Dim counterRow, counterColumn, counterTarget As Integer
Dim tempString As String
Set sourceSheet = Application.ActiveWorkbook.Worksheets("Sheet1")
Set targetSheet = Application.ActiveWorkbook.Worksheets("Sheet2")
counterRow = 0
counterTarget = 0
Do While sourceSheet.Range("A1").Offset(counterRow, 0).Value <> ""
tempString = sourceSheet.Range("A1").Offset(counterRow, 0).Value
counterColumn = 1
Do While sourceSheet.Range("A1").Offset(counterRow, counterColumn).Value <> ""
targetSheet.Range("A1").Offset(counterTarget, 0).Value = tempString
targetSheet.Range("A1").Offset(counterTarget, 1).Value = _
sourceSheet.Range("A1").Offset(counterRow, counterColumn).Value
counterTarget = counterTarget + 1
counterColumn = counterColumn + 1
Loop
counterRow = counterRow + 1
Loop
End Sub