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
Related
I also need to apply Match function in VBA, and the Arg 1 also has to be Date. The Array (Arg 2) I defined in the "Name Manager" (Tab Formula of Excel). I need to use the Name Manager since I have several array/ table reference based on the type of currency. For example, if the currency is USD, the reference table is USDREF which I defined as Range("B21:B36"). For the other currency, ex. JPY, I use array/ table reference JPYREF which is defined as JPYREF from Range("B36:B50"). It applies for other currencies. Here's my code :
Dim Original As Workbook
Dim SRate As Worksheet
Dim ccy As String
Dim i, j, k, l, Rank1, Rank2, Rate1, Rate2 As Integer
Dim srow, erow, x As Long
Dim DateFCYIDR, Date1, Date2 As Date
Sub fcyidr()
Set Original = ThisWorkbook
Set SRate = Original.Sheets("Rate")
SRate.Activate
Range("A36").Select
ccy = ActiveCell.Value
While ActiveCell.Value <> ""
For i = 1 To 15
If i = 1 Or i = 15 Then
j = ActiveCell.Row
ActiveCell.Offset(0, 8) = "=+$G$" & j - 15 & "/G" & j
ActiveCell.Offset(1, 0).Select
Else
DateFCYIDR = ActiveCell.Offset(0, 7).Value
Rank1 = WorksheetFunction.Match(CLng(DateFCYIDR), USDREF, 0)
End If
Next i
Wend
where USDREF is defined in Name Manager. But it didn't work.
How do I solved the problem?
I have a sheet with three columns as illustrated below
Id
StartDate
EndDate
1
20201101
20210131
2
20200801
20201031
2
20201101
99991231
3
20200901
99991231
3
20210301
99991231
4
20200301
20200930
4
20201001
20210430
4
20210315
99991231
I want to test if there are overlapping time ranges within each group of duplicate ids.
For example, the two rows with id = 3 have overlapping time ranges. The same goes for the last two rows of id = 4.
So I imagine that whenever the loop(?) finds an overlap, it throws me a msgbox with the corresponding id.
How can I achieve this?
I'm thinking that it might require a nested loop? And to test for overlap I would use the following logic:
If StartDate1 <= EndDate2 And StartDate2 <= EndDate1 Then ...
You are rigth, a nested loop should do the job, and inside the loop you can test if the cells have the same ID
I think this code will solve your problem:
Sub overlap()
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Sheet1")
last_line = ws.Range("a100000").End(xlUp).Row
For i = 2 To last_line
StartDate1 = ws.Cells(i, 2)
EndDate1 = ws.Cells(i, 3)
ID1 = ws.Cells(i, 1)
For j = i + 1 To last_line
ID2 = ws.Cells(j, 1)
If ID1 = ID2 Then
StartDate2 = ws.Cells(j, 2)
EndDate2 = ws.Cells(j, 3)
If StartDate1 <= EndDate2 And StartDate2 <= EndDate1 Then
MsgBox "overlap at row: " & i & " (ID: " & ID1 & ")"
End If
End If
Next j
Next i
End Sub
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
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 am trying to add values from different sheets (Sheet 2 to 5) into my main sheet (Sheet 1). In Sheet 1 I want the cells to contain the right formula pointing to the different sheets (if possible).
Typically like this:
='Sheet2'!D5+'Sheet3'!D165
All my sheets have different products, but some sheets contain same products. So I want to search through them all and ADD them in my Main Sheet (Sheet 1).
Sub UpdateMainSheet()
' Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Count As Integer
'Line of code to delete old data in Main Sheet:
Worksheets("Sheet1").Range("A2:H10000").Clear
AktivtArkOverskrift = "List of Articles from Sheet 2 to 5"
'Creates Headline in Main Sheet:
eRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets("Sheet1").Cells(eRow, 1) = AktivtArkOverskrift
Worksheets("Sheet1").Cells(eRow, 1).Font.Bold = True
'Script to check and gather data from the other sheets (Sheet 2, 3, 4 and 5):
For K = 2 To 5
'For loop to check each line in sheet "K"
For I = 2 To 1000
'If function to check if the cell I in column F is empty, if so it_jumps to next row and do the same check:
If Worksheets(K).Cells(I, 6) > 0 Then
Count = 0
'For loop to check if I already have a row in the Main Sheet with the article I'm checking:
For L = 2 To 1000
'If function to check if the articles have the same article number:
If Worksheets(K).Cells(I, 1) = Worksheets("Sheet1").Cells(L, 1) Then
'Line of code that are supposed to ADD the values that is currently in the Main Sheet, togheter with the value in Sheet K:
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
End If
Next L
End If
Next I
Next K
End Sub
So what I need to fix in my code is this part (located furthest inside the For Loop):
Worksheets("Sheet1").Cells(I, 4).Formula = Worksheets("Sheet1").Cells(I, 4) + Worksheets(K).Cells(L, 4)
And make it create a formula in the wanted cell, that looks something like this:
='Sheet2'!D5+'Sheet3'!D165
It must be able to add another cell as well, since the Loop are running through several Sheets (Sheet 2 to 5) that may contain the same products.
I.e. I only want one line in my Main Sheet for each product.
I managed to find the solution in the end.
It seemed I had switched the L and I in som of the looping, which resulted in the values not to be added togheter.
The following code (I did not translate to English, but can do this if someone wants/need it) solved my issue, and gave me the values from Sheet 2 to 5 sorted by product in Sheet 1:
Sub OppdaterePlukkelisteSummert()
'Kode for å Oppdatere Plukkeliste Alle Artikler Summert
Dim AktivtArk As String
Dim AktivtArkNavn As String
Dim K As Integer
Dim Teller As Integer
Dim value1 As Integer
Dim value2 As Integer
'Sletter Plukklisten for å oppdatere og sortere på nytt:
Worksheets(1).Range("A2:H10000").Clear
'HENTING AV DATA FRA ARKET "K":
AktivtArk = "Artikler Summert fra Alle Ark"
AktivtArkOverskrift = "Artikler Summert fra Alle Ark"
'Setter inn Overskrift som Forteller kva ark utstyret kommer fra:
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Worksheets(1).Cells(eRow, 1) = AktivtArkOverskrift
Worksheets(1).Cells(eRow, 1).Font.Bold = True
'Sjekker hvilke/hvilket rader/utstyr som skal plukkes, og legger det inn i "Ark1":
For K = 2 To 5
For I = 2 To 1000
If Worksheets(K).Cells(I, 6) > 0 Then
Teller = 0
For L = 2 To 1000
If Worksheets(K).Cells(I, 1) = Worksheets(1).Cells(L, 1) Then
value1 = Worksheets(1).Cells(L, 4)
value2 = Worksheets(K).Cells(I, 4)
Worksheets(1).Cells(L, 4) = value1 + value2
Worksheets(1).Cells(L, 6) = value1 + value2
Else
Teller = Teller + 1
End If
Next L
If Teller > 998 Then
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For J = 1 To 11
Worksheets(1).Cells(eRow, J) = Worksheets(K).Cells(I, J)
Next J
Worksheets(1).Cells(eRow, 6).Font.Color = RGB(0, 150, 0)
Worksheets(1).Cells(eRow, 7).Font.Color = RGB(0, 150, 0)
End If
End If
Next I
Next K
Worksheets(1).Range("A2").Select
End Sub
I hope this can be useful for someone else :-)
All help and suggestion in the comments are appreciated!
I was going to illustrate with this simple example:
I = 1 'for example
For K = 2 To 5
Worksheets("Sheet1").Cells(I, 4).Value = Worksheets("Sheet1").Cells(I, 4).Value + _
WorksheetFunction.SumIf(Worksheets(K).Range("A:A"), "Bananas", Worksheets(K).Range("D:D"))
Next K