I have an Excel Sheet where some rows may contain the same data as other rows, except for one column. I need a macro to sum all the values in that column and delete all the duplicates, except for the first one, which contains the sum of the rest. For example:
A B C D
1 a b c d
2 n j i o
3 a b c p
4 v y e b
5 a b c m
6 . . . .
In this case, the code must delete rows 3 and 5 (because they are "duplicates" of row 1), and replace the column D of row 1 with d+p+m. I managed to come up with the following code:
For j = 1 To Range("A1").End(xlDown).Row
For i = j + 1 To Range("A1").End(xlDown).Row
If Cells(j, 1).value = Cells(i, 1).value And Cells(j, 2).value = Cells(i, 2).value And Cells(j, 3).value = Cells(i, 3).value Then
Cells(j, 6) = Cells(i, 6).value + Cells(j, 6).value
Rows(i).Delete Shift:=xlUp
i = i - 1
End If
Next i
Next j
But as you may have already noticed, it's very inefficient and basic. Any better ideas?
Here is a simple code:
Sub remdup()
Dim ws As Worksheet
Dim lastrw As Long
Set ws = ActiveSheet
lastrw = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("E1:E" & lastrw).FormulaR1C1 = "=SUMIFs(C[-1],C[-4],RC[-4],C[-3],RC[-3],C[-2],RC[-2])"
ws.Range("D1:D" & lastrw).Value = ws.Range("E1:E" & lastrw).Value
ws.Range("E1:E" & lastrw).ClearContents
With ws.Range("A1:D" & lastrw)
.Value = .Value
.RemoveDuplicates Array(1, 2, 3), xlNo
End With
End Sub
Related
I have 2 workbooks called "Source1" and "Source2".
For each cell in the last column of "Source1" I check if it exists in the last column of "Source2".
If yes, then I copy 4 separate cells from that row based on some critea into a new workbook called "Target".
My macro is working but as I have thousands of cells to loop through, it takes me at least 10 min till the macro finishes. I am running it many times a day so I want to optimize my code so that it will take less time.
Here is my code
Sub Loop_Cells()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Dim Source, Source2, Target As Workbook
Dim c As Range
Dim lRow, lRow2 As Long
Dim x, y, w As Integer
Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")
Source.Activate
x = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, x + 1) = "Concate"
lRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
ActiveSheet.Cells(i, x + 1).Value = ActiveSheet.Cells(i, 6).Value & ActiveSheet.Cells(i, 7).Value
Next i
ActiveSheet.Columns(x + 1).NumberFormat = "0"
Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")
Source2.Activate
y = ActiveSheet.UsedRange.Columns.Count
ActiveSheet.Cells(1, y + 1) = "Concate"
lRow2 = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow2
ActiveSheet.Cells(i, y + 1).Value = ActiveSheet.Cells(i, 48).Value & ActiveSheet.Cells(i, 3).Value
Next i
ActiveSheet.Columns(y + 1).NumberFormat = "0"
Set Target = Workbooks.Add
Target.Sheets(1).Name = "ExistCells"
Source.Sheets(1).Activate
w = 1
For Each c In Source1.Sheets(1).UsedRange.Columns(x + 1).Cells
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then
Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value
w = w + 1
End If
Next j
Next c
Workbooks("Source1.xlsx").Close SaveChanges:=False
Workbooks("Source1.xlsx").Close SaveChanges:=False
Target.Activate
ActiveWorkbook.SaveAs FileName:= "C:\Reports\Target.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I think the problem is in this part, when the cell exists I don't need to loop till the last row and I should move to the next.
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then ...
Any Suggestions how to adjust my code?
Collections: VBA.Collection, Scripting.Dictionary, ArrayList, Queue, Stack ... etc.
Collections are optimized for fast lookups. For this reason,they are ideal when matching values.
Consider matching two lists each with 1000 values. Assuming that on average you find a match half way through the list, that's (500 * 1000) or 500K operations. Using a Collection would reduce the number to 1000 iterations + 1000 lookups. Assuming that it takes 1 to 10 operations per lookup (just a guess) then you would reduce the number of operations that it takes to compare two 1000 element lists from 500K to 6K.
Arrays: Reading and writing to arrays is much faster then reading and writing to file (worksheet).
Once a match is found you write 4 values to the new worksheet. Let's say you find 1000 matches, that's 4000 write operations to the worksheet. If instaed you hold these values in an array and then write the array to the worksheet you'll reduce the number of write operations (to the worksheet) from 400 to 1.
Using these techniques should reduce the run time from 10+ minutes to under 20 seconds.
Sub NewLoop()
Application.ScreenUpdating = False
Application.SheetsInNewWorkbook = 1
Dim data As Variant, result As Variant
Dim lastRow As Long, x As Long, x1 As Long
Dim key As String
Dim list As Object
Set list = CreateObject("System.Collections.ArrayList")
With Workbooks.Open("C:\Reports\Source1.xlsx")
With .Worksheets(1)
data = .Range("F2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
For x = 1 To UBound(data, 1)
'Create a Unique Identifier using a pipe to delimit the data
'This will keep the data from mixing
key = data(x, 1) & "|" & data(x, 2)
If Not list.Contains(key) Then list.Add key
Next
End With
.Close SaveChanges:=False
End With
With Workbooks.Open("C:\Reports\Source2.xlsx")
With .Worksheets(1)
lastRow = .Range("A" & Rows.Count).End(xlUp).Row
ReDim result(1 To lastRow, 1 To 4)
For x = 2 To lastRow
'Create a Unique Identifier using a pipe to delimit the data
'This will keep the data from mixing
key = .Cells(i, 48).Value & "|" & .Cells(i, 3).Value
If list.Contains(key) Then
x1 = x1 + 1
result(x1, 1) = .Cells(j, 48).Value
result(x1, 2) = .Cells(j, 3).Value
result(x1, 3) = .Cells(j, 27).Value
result(x1, 4) = .Cells(j, 41).Value
End If
Next
End With
.Close SaveChanges:=False
End With
With Workbooks.Add
With Worksheets(1)
.Name = "ExistCells"
.Range("A1:D1").Resize(x1).Value = Results
End With
End With
Application.ScreenUpdating = True
End Sub
Following on from your last point, could you not just exit the loop when the If condition is met? Something like this for example?
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1).Value Then
Target.Sheets(1).Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48).Value
Target.Sheets(1).Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3).Value
Target.Sheets(1).Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27).Value
Target.Sheets(1).Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41).Value
w = w + 1
GoTo ExitLoop
End If
Next j
ExitLoop:
The code could be cleaned up a bit...plus you were closing "Source1.xlsx" twice...and tried to refer to Source1 as a variable even though it was never declared. Using Option Explicit at the top of the module will allow you find that type of issue easily. I put in a similar break in the inner For loop like Wilson88 as well.
By using your variables and With you should be able to speed it up some over ActiveWorkbook and ActiveSheet...
Sub Loop_Cells()
Dim Source As Workbook, Source2 As Workbook, Target As Workbook
Dim w As Integer, x As Integer, y As Integer
Dim lRow As Long, lRow2 As Long
Dim c As Range
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.SheetsInNewWorkbook = 1
Set Source = Workbooks.Open("C:\Reports\Source1.xlsx")
With Source
x = .UsedRange.Columns.Count
.Cells(1, x + 1) = "Concate"
lRow = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow
.Cells(i, x + 1) = .Cells(i, 6). & .Cells(i, 7)
Next i
.Columns(x + 1).NumberFormat = "0"
End With
Set Source2 = Workbooks.Open("C:\Reports\Source2.xlsx")
With Source2
y = .UsedRange.Columns.Count
.Cells(1, y + 1) = "Concate"
lRow2 = .Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lRow2
.Cells(i, y + 1). = .Cells(i, 48) & .Cells(i, 3)
Next i
.Columns(y + 1).NumberFormat = "0"
End With
Set Target = Workbooks.Add
With Target.Sheets(1)
.Name = "ExistCells"
w = 1
For Each c In Source.Sheets(1).UsedRange.Columns(x + 1).Cells
For j = 2 To lRow2
If c.Value = Source2.Sheets(1).Cells(j, y + 1) Then
.Cells(w, 1).Value = Source2.Sheets(1).Cells(j, 48)
.Cells(w, 2).Value = Source2.Sheets(1).Cells(j, 3)
.Cells(w, 3).Value = Source2.Sheets(1).Cells(j, 27)
.Cells(w, 4).Value = Source2.Sheets(1).Cells(j, 41)
w = w + 1
Exit For
End If
Next j
Next c
End With
Source.Close SaveChanges:=False
Source2.Close SaveChanges:=False
Target.SaveAs FileName:= "C:\Reports\Target.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
I need help combining rows with VBA in Excel dynamically where the value is sometimes the same in one column.
Sample Data
A B C D E
1 r 10 5 3
1 r 12 8 2
2 q 60 50 40
2 q 25 45 55
2 q 100 200 300
EDIT: mistake in my sample data, changed last value in A from 3 to 2.
Ideally, I would combine the rows where the value is the same below in column B and while combining the values in C & D separated by semi colon and summing the values in column E.
It works when there is one duplicate, but not varying numbers of duplicates (dynamic combining)
Here is basically what I have tried:
Dim i As Long
i = 2
For i = 2 to lastRow
If Cells(i, 2).Value = Cells(i + 1, 2).Value Then
Cells(i, 3).Value = Cells(i, 3).Value & ";" & Cells(i + 1, 3).Value
Cells(i, 4).Value = Cells(i, 4).Value + Cells(i + 1, 4).Value
Rows(i + 1).Delete
Else
i = i + 1
End If
Loop
We can work backwards. Before:
The sub:
Sub dural()
Dim i As Long
lastRow = 5
For i = lastRow To 2 Step -1
If Cells(i, 2).Value = Cells(i - 1, 2).Value Then
Cells(i - 1, 3).Value = Cells(i - 1, 3).Value & ";" & Cells(i, 3).Value
Cells(i - 1, 4).Value = Cells(i - 1, 4).Value + Cells(i, 4).Value
Rows(i).Delete
End If
Next i
End Sub
and after:
I think this will do what you want.
Sub Macro()
Dim lngRow As Long
For lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 Then
If Range("C" & lngRow) <> "" Then
Range("C" & lngRow - 1) = Range("C" & lngRow - 1) & "|" & Range("C" & lngRow) & _
Range("D" & lngRow - 1) & ";" & Range("D" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
Columns("D:E").Select
Selection.ClearContents
End Sub
I am new here.
I am trying to build a quick VBA program to "flatten" a Bill of Materials by heirarchy (BOM Level) and Status.
Here is some sample data:
The sample data shows a BOM with a Car as a top level assembly, Wheel and Engine as second level assemblies, and various children parts that make up those assemblies on the third and fourth level of the BOM.
I want to delete any rows that have the value "ZE", "ZM", or blank in column C.
I also want to delete any rows that have the value "ZA" and are also direct children of another "ZA" item. (Example - Delete the Rim row from the BOM because the Wheel is the Parent "ZA" item)
Here is what I have so far:
Sub deletechildren()
Dim lr As Long, i As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
If i > 2 Then
k = i - 1
End If
If Cells(i, 3).Value = "ZA" And Cells(i, 1).Value = Cells(k, 1).Value Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "ZE" Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "ZM" Then
Cells(i, 3).EntireRow.Delete
ElseIf Cells(i, 3).Value = "" Then
Cells(i, 3).EntireRow.Delete
End If
Next i
lr = Cells(Rows.Count, 1).End(xlUp).Row
End Sub
I am getting some error on the first part of the If statement, where I want to parse out any "ZA" status children from the "ZA" parent.
Any ideas?
Sub DeleteChildren()
Dim lastRow As Long
Dim i As Long
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRow
If (Cells(i, 3).Value = "ZE" Or Cells(i, 3).Value = "ZM" Or Cells(i, 3).Value = "") And Cells(i, 1) <> "" Then
Rows(i).EntireRow.Delete xlShiftUp
i = i - 1
GoTo NextIteration
End If
If Cells(i, 1).Value > 1 Then
If (Cells(i, 3).Value = "ZA" And Cells(i - 1, 3).Value = "ZA") And Not Cells(i, 1).Value < Cells(i - 1, 1).Value Then ' This way is a there are multiple levels with "ZA" there can
Cells(i, 5).Value = "Delete"
End If
End If
NextIteration:
Next i
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, 5).Value = "Delete" Then
Rows(i).EntireRow.Delete xlShiftUp
i = i - 1
End If
Next i
End Sub
A part of the problem is that the variable k is not being used to correctly identify parent/children relationships (if I understand your requirements correctly). In your case, you are comparing the each value with the row above it, but in a bill of materials, the parent row might be multiple rows above, and is denoted by a hierarchy value - 1.
See my revised code below. In the code, we first delete any rows that we know to delete (ZM, ZE, and Blanks). Next, we loop up the hierarchy values until we find one hierarchy value above the current row. That becomes the parent row, and from there, we test.
Let me know if you need additional help.
Sub deletechildren()
Dim lr As Long, i As Long, k As Long
lr = Cells(Rows.Count, 1).End(xlUp).Row
For i = lr To 1 Step -1
If i > 2 Then
k = i - 1
If Cells(i, 3) = "ZE" Or Cells(i, 3) = "ZM" Or Cells(i, 3) = "" Then
Rows(i).Delete
Else
k = i - 1
Do Until i <= 2 Or (Cells(i, 1) - Cells(k, 1) = 1)
k = k - 1
Loop
'Now, k represents the parent row.
If Cells(i, 3) = "ZA" And Cells(k, 3) = "ZA" Then
Rows(i).Delete
End If
End If
End If
Next i
lr = Cells(Rows.Count, 1).End(xlUp).Row
End Sub
I'd use Autofilter() and Sort() methods of Range object like follows:
Option Explicit
Sub deletechildren()
Dim i As Long
With Worksheets("BOM")
With .Range("A1:D" & .Cells(.Rows.Count, 1).End(xlUp).Row)
.AutoFilter Field:=3, Criteria1:=Array("ZE", "ZM", "="), Operator:=xlFilterValues
With .Offset(1).Resize(.Rows.Count - 1)
If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then .SpecialCells(xlCellTypeVisible).EntireRow.Delete
End With
.AutoFilter
.Sort key1:=Range("C1"), order1:=xlAscending, key2:=Range("A1"), order2:=xlAscending, Header:=xlYes
i = .Rows(.Rows.Count).Row
Do Until .Cells(i, 1) = .Cells(2, 1)
i = i - 1
Loop
If i < .Rows.Count Then .Rows(i + 1).Resize(.Rows.Count - i).EntireRow.Delete
End With
End With
End Sub
I have written a bit of code that is intended to search cells in a column, see if they start with a certain string and then return a value based on that string in another column. I have two problems, firstly the loops don't actually return any values in columns 8,9,10 or 11. Also the second loop doesn't stop running? Here is my code
Sub Possible_solution_one()
Dim i As Integer
Dim j As Integer
Dim ws As Worksheet
Set ws = ActiveSheet
For i = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(i, 1).Value <> ""
If Cells(i, 2) = "Business://EXTRACTS/" & "*" Then
Cells(i, 8) = "OBS(" & Cells(i, 2).Value & ",SHARE,#DI) OR "
End If
i = i + 1
Loop
Next
For j = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(j, 6).Value <> ""
If Cells(j, 6) = "Business" & "*" Then
Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
ElseIf Cells(j, 6) = "CSTM" Then
Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
ElseIf Cells(j, 6) = "*FS" Then
Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
i = i + 1
Loop
Next
End Sub
To give the situation I have 1 type of string in column B and 3 types in column F. Am looking to return different things in columns 8,9,10,11 based on b and D
If you are pattern matching with wildcards, you need to use the Like operator. e.g. If Cells(i, 2) Like "Business://EXTRACTS/" & "*" Then
The Do While loops inside the For Next loops were unnecessary. It is also not a good idea to 'manually' increment the increment counter in a For ... Next loop.
The second loop was running forever because you were incrementing i, not j.
A Select Case statement would make a better fit for the multiple criteria in the second j loop.
Sub Possible_solution_one()
Dim i As Long, j As Long
Dim ws As Worksheet
Set ws = ActiveSheet
With ws
For i = 2 To .Cells(.Rows.Count, "a").End(xlUp).Row
If Not CBool(Len(Cells(i, "a").Value)) Then Exit For
If .Cells(i, 2) = "Business://EXTRACTS/" & "*" Then
.Cells(i, 8) = "OBS(" & .Cells(i, 2).Value & ",SHARE,#DI) OR "
End If
Next i
For j = 2 To .Cells(ws.Rows.Count, "a").End(xlUp).Row
Select Case .Cells(j, 6).Value
Case "Business*"
.Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
Case "CSTM"
.Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
Case "*FS"
.Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
End Select
Next j
End With
End Sub
I've also incorporated a With ... End With statement to associate all of the cells to the parent ws worksheet. Note hte .Cells and not Cells. The prefixing period assigns parentage to the worksheet referenced in the With ... End With.
With no sample data, I could not completely test this rewrite but it does compile.
your second do while loop uses i=i+1 instead of j = j + 1 so it's not going to increment the cells(j, 6).value if there's anything in cells(j,6) then the loop won't stop running
For j = 2 To ws.Cells(ws.Rows.Count, "a").End(xlUp).Row
Do While Cells(j, 6).Value <> ""
If Cells(j, 6) = "Business" & "*" Then
Cells(j, 9) = "OBS(" & Cells(j, 4).Value & ",SHARE,DI) OR "
ElseIf Cells(j, 6) = "CSTM" Then
Cells(j, 10) = "PUM(" & Cells(j, 4).Value & ",#D7) OR "
ElseIf Cells(j, 6) = "*FS" Then
Cells(j, 11) = "FCON(" & Cells(j, 4).Value & ") OR "
End If
'i = i + 1
j = j + 1
Loop
Next
I’m new to VBA and have been searching the solution from long time.
I need the data to perform Vlookup with another set of data having common IDs
I have data like given below.
ID Status Package
0001 ACT Gold
0001 ACT SSA
0001 ACT SP
0002 ACT Silver
0003 DIS SSA
0003 DIS SSB
0004 ACT PT
0005 DIS NP
0006 DIS <Blank >
And I need it in following structure
ID Status Package1 Package 2 Package 3….
0001 ACT Gold SSA SP
0002 ACT Silver
0003 DIS SSA SSB
0004 ACT PT
0005 DIS NP
0006 DIS
Number of packages can vary from 0 to 15.
Also how to do reverse operation? (secondary requirement)
Tried this code (!) but result for values with 1 or no parameters was not accurate.
Sub test()
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dim CLa As Range, CLb As Range, x&, Names$, ID$, Key
' Sheet1 is a Source Sheet
' Sheet3 is a Target Sheet
x = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For Each CLa In Sheets("Sheet1").Range("A1:A" & x)
If Not Dic.exists(CStr(CLa.Value)) Then
ID = CLa.Value
' Sheet1 is a Source Sheet
' Sheet3 is a Target Sheet
For Each CLb In Sheets("Sheet1").Range("A1:A" & x)
If CLb.Value = ID Then
If Names = "" Then
Names = CLb.Offset(, 2).Value
Else
Names = Names & "," & CLb.Offset(, 2).Value
End If
End If
Next CLb
Dic.Add ID, Names
End If
ID = Empty: Names = Empty
Next CLa
x = 1
For Each Key In Dic
Sheets("Sheet3").Cells(x, 1).Value = Key
Sheets("Sheet3").Range(Cells(x, 2), Cells(x, 4)) = Split(Dic(Key), ",")
x = x + 1
Next Key
Sheets("Sheet3").Cells.Replace "#N/A", Replacement:=""
End Sub
I would use a simple formula:
="Package"&COUNTIF($A$1:$A2;A2)
It creates your matching names and then you can use a Pivot to summarize. Of course you could set up loops through for each separate ID.
The reverse is more tricky, I'd resort to something along the lines of
Sub ertdfgcvb()
Dim ws As Worksheet, wsex As Worksheet, k As Long, i As Long, j As Long, LastRow As Long
Set ws = Sheets("tabular form")
Set ws = Sheets("dataset form")
k = 2
LastRow = ws.Cells.Find(What:="*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For i = 2 To LastRow 'from the second to the last row
j = 3 'start at Package1
While Not IsEmpty(ws.Cells(i, j))
wsex.Cells(k, 1).Value2 = ws.Cells(i, 1).Value2 'copies the ID from the A column
wsex.Cells(k, 2).Value2 = ws.Cells(i, 2).Value2 'Copies status likewise
wsex.Cells(k, 3).Value2 = ws.Cells(i, j).Value2 'copies Package<n>
'wsex.Cells(k, 4).Value2 = "Package" & j - 2 'copies "Package<n>"
k = k + 1 'increases counters
j = j + 1
Wend
Next i
End Sub
This can be done with a simple loop
Sub Transpose()
writeRow = 1
LastRow = Columns(1).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For i = 2 To LastRow
If Cells(i, 1).Value <> currentID Then
'New ID
writeRow = writeRow + 1
currentID = Cells(i, 1).Value
Cells(writeRow, 5).Value = currentID
Cells(writeRow, 6).Value = Cells(i, 2).Value
Cells(writeRow, 7).Value = Cells(i, 3).Value
Else
'Continue from old ID
Cells(writeRow, Rows(writeRow).Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column + 1).Value = Cells(i, 3).Value
End If
Next i
End Sub
I didn't read that you also need a reverse routine. Try these:
Sub Transpose()
Cells(2, 5).CurrentRegion.ClearContents
writeRow = 1
For i = 2 To Columns(1).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
If Cells(i, 1).Value <> currentID Then
'New ID
writeRow = writeRow + 1
currentID = Cells(i, 1).Value
Cells(writeRow, 5).Value = currentID
Cells(writeRow, 6).Value = Cells(i, 2).Value
Cells(writeRow, 7).Value = Cells(i, 3).Value
writeCol = 8
Else
'Continue from old ID
Cells(writeRow, writeCol).Value = Cells(i, 3).Value
writeCol = writeCol + 1
End If
Next i
End Sub
Sub ReverseTranspose()
Cells(2, 1).CurrentRegion.ClearContents
writeRow = 1
For i = 2 To Columns(5).Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious).Row
For j = 7 To WorksheetFunction.Max(7, Rows(i).Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious).Column)
writeRow = writeRow + 1
currentID = Cells(i, 5).Value
Cells(writeRow, 1).Value = currentID
Cells(writeRow, 2).Value = Cells(i, 6).Value
Cells(writeRow, 3).Value = Cells(i, j).Value
Next j
Next i
End Sub