Sub Macro2()
Dim lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, r As Long
lr = Sheets("Sheet Piles Summary").Cells(Rows.Count, "I").End(xlUp).Row
lr2 = Sheets("1000").Cells(Rows.Count, "A").End(xlUp).Row
lr3 = Sheets("2000").Cells(Rows.Count, "A").End(xlUp).Row
lr4 = Sheets("3000").Cells(Rows.Count, "A").End(xlUp).Row
lr5 = Sheets("4000").Cells(Rows.Count, "A").End(xlUp).Row
lr6 = Sheets("5000").Cells(Rows.Count, "A").End(xlUp).Row
lr7 = Sheets("6000").Cells(Rows.Count, "A").End(xlUp).Row
For r = lr To 2 Step -1
Select Case Range("I" & r).Value
Case Is = "1000"
Rows(r).Copy Destination:=Sheets("1000").Range("A" & IIf(lr2 = 1, lr2 + 2, lr2 + 1))
lr2 = Sheets("1000").Cells(Rows.Count, "A").End(xlUp).Row
Case Is = "2000"
Rows(r).Copy Destination:=Sheets("2000").Range("A" & IIf(lr3 = 1, lr3 + 2, lr3 + 1))
lr3 = Sheets("2000").Cells(Rows.Count, "A").End(xlUp).Row
Case Is = "3000"
Rows(r).Copy Destination:=Sheets("3000").Range("A" & IIf(lr4 = 1, lr4 + 2, lr4 + 1))
lr4 = Sheets("3000").Cells(Rows.Count, "A").End(xlUp).Row
Case Is = "4000"
Rows(r).Copy Destination:=Sheets("4000").Range("A" & IIf(lr5 = 1, lr5 + 2, lr5 + 1))
lr5 = Sheets("4000").Cells(Rows.Count, "A").End(xlUp).Row
Case Is = "5000"
Rows(r).Copy Destination:=Sheets("5000").Range("A" & IIf(lr6 = 1, lr6 + 2, lr6 + 1))
lr6 = Sheets("5000").Cells(Rows.Count, "A").End(xlUp).Row
Case Is = "6000"
Rows(r).Copy Destination:=Sheets("6000").Range("A" & IIf(lr7 = 1, lr7 + 2, lr7 + 1))
lr7 = Sheets("6000").Cells(Rows.Count, "A").End(xlUp).Row
End Select
Next r
End Sub
Something like below?
Code:Sub Macro2() Dim lr As Long, lr2 As Long, lr3 As Long, lr4 As Long, lr5 As Long, lr6 As Long, lr7 As Long, r As Long lr = Sheets("Sheet Piles Summary").Cells(Rows.Count, "I").End(xlUp).Row lr2 = Sheets("1000").Cells(Rows.Count, "A").End(xlUp).Row lr3 = Sheets("2000").Cells(Rows.Count, "A").End(xlUp).Row lr4 = Sheets("3000").Cells(Rows.Count, "A").End(xlUp).Row lr5 = Sheets("4000").Cells(Rows.Count, "A").End(xlUp).Row lr6 = Sheets("5000").Cells(Rows.Count, "A").End(xlUp).Row lr7 = Sheets("6000").Cells(Rows.Count, "A").End(xlUp).Row For r = lr To 2 Step -1 Select Case Range("I" & r).Value Case Is = "1000" Rows(r).Copy Destination:=Sheets("1000").Range("A" & IIf(lr2 = 1, lr2 + 2, lr2 + 1)) lr2 = Sheets("1000").Cells(Rows.Count, "A").End(xlUp).Row Case Is = "2000" Rows(r).Copy Destination:=Sheets("2000").Range("A" & IIf(lr3 = 1, lr3 + 2, lr3 + 1)) lr3 = Sheets("2000").Cells(Rows.Count, "A").End(xlUp).Row Case Is = "3000" Rows(r).Copy Destination:=Sheets("3000").Range("A" & IIf(lr4 = 1, lr4 + 2, lr4 + 1)) lr4 = Sheets("3000").Cells(Rows.Count, "A").End(xlUp).Row Case Is = "4000" Rows(r).Copy Destination:=Sheets("4000").Range("A" & IIf(lr5 = 1, lr5 + 2, lr5 + 1)) lr5 = Sheets("4000").Cells(Rows.Count, "A").End(xlUp).Row Case Is = "5000" Rows(r).Copy Destination:=Sheets("5000").Range("A" & IIf(lr6 = 1, lr6 + 2, lr6 + 1)) lr6 = Sheets("5000").Cells(Rows.Count, "A").End(xlUp).Row Case Is = "6000" Rows(r).Copy Destination:=Sheets("6000").Range("A" & IIf(lr7 = 1, lr7 + 2, lr7 + 1)) lr7 = Sheets("6000").Cells(Rows.Count, "A").End(xlUp).Row End Select Next r End Sub
Though I'd suggest using AutoFilter and then copy paste rather than iterating through each row.
Dear
Dear Chihiro,
Please let me know how to shorten the code if let's say i have over 20 sheets without duplicating the rows code 20 times?
Thank you.
Regards,
Michelle
I'm bit busy today. Will look at it tomorrow.
Sub Demo()
Dim shRange
Dim dic As Object, Key
shRange = Cells(4, 1).CurrentRegion.Columns(1).Value
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(shRange, 1)
If shRange(i, 1) <> "" Then
dic.Item(shRange(i, 1)) = CStr(shRange(i, 1))
End If
Next
For Each Key In dic.Keys
If Not IsObject(ThisWorkbook.Sheets(dic(Key))) Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = dic(Key)
End If
Sheets(dic(Key)).Cells.Clear
With Sheets("Sheet Piles Summary")
If .AutoFilterMode = True Then .AutoFilterMode = False
.Range("A3:E" & .Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Key
.Cells(1).CurrentRegion.Copy Sheets(dic(Key)).Cells(1)
.AutoFilterMode = False
End With
Next
End Sub
Something like below?
Code:Sub Demo() Dim shRange Dim dic As Object, Key shRange = Cells(4, 1).CurrentRegion.Columns(1).Value Set dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(shRange, 1) If shRange(i, 1) <> "" Then dic.Item(shRange(i, 1)) = CStr(shRange(i, 1)) End If Next For Each Key In dic.Keys If Not IsObject(ThisWorkbook.Sheets(dic(Key))) Then Worksheets.Add After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = dic(Key) End If Sheets(dic(Key)).Cells.Clear With Sheets("Sheet Piles Summary") If .AutoFilterMode = True Then .AutoFilterMode = False .Range("A3:E" & .Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Key .Cells(1).CurrentRegion.Copy Sheets(dic(Key)).Cells(1) .AutoFilterMode = False End With Next End Sub
Bonus: You can shorten Column J formula to...
=IF(ISNUMBER(MID(B4,5,1)*1),MID(B4,5,1)*1000,"CHECK")
Dear Chihiro,
Thank you! It's exactly what I am looking for! Just 2 things.
1. Is there a way to keep the sheets with no fill pattern style to make it more presentable because I need to paste this in Autocad
2. Is there a way to shorten my formula in column D?
Regards,
Michelle
Sub Demo()
Dim shRange
Dim dic As Object, Key
shRange = Cells(4, 1).CurrentRegion.Columns(1).Value
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(shRange, 1)
If shRange(i, 1) <> "" Then
dic.Item(shRange(i, 1)) = CStr(shRange(i, 1))
End If
Next
For Each Key In dic.Keys
If Not IsObject(ThisWorkbook.Sheets(dic(Key))) Then
Worksheets.Add After:=Worksheets(Worksheets.Count)
Worksheets(Worksheets.Count).Name = dic(Key)
End If
Sheets(dic(Key)).Cells.Clear
With Sheets("Sheet Piles Summary")
If .AutoFilterMode = True Then .AutoFilterMode = False
.Range("A3:E" & .Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Key
.Cells(1).CurrentRegion.Offset(, 1).Resize(, .Cells(1).CurrentRegion.Columns.Count - 1).Copy Sheets(dic(Key)).Cells(1)
Sheets(dic(Key)).Activate
ActiveWindow.DisplayGridlines = False
ActiveSheet.Columns.AutoFit
.AutoFilterMode = False
.Activate
End With
Next
End Sub
2. Is there a way to shorten my formula in column D?
Can I have a code based on the 5th character of the cell instead of making a dummy at column A. Like for example if the 5th character of cell B is "1" then it will go to sheet "1000".
Try something like below.
Code:Sub Demo() Dim shRange Dim dic As Object, Key shRange = Cells(4, 1).CurrentRegion.Columns(1).Value Set dic = CreateObject("Scripting.Dictionary") For i = 1 To UBound(shRange, 1) If shRange(i, 1) <> "" Then dic.Item(shRange(i, 1)) = CStr(shRange(i, 1)) End If Next For Each Key In dic.Keys If Not IsObject(ThisWorkbook.Sheets(dic(Key))) Then Worksheets.Add After:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).Name = dic(Key) End If Sheets(dic(Key)).Cells.Clear With Sheets("Sheet Piles Summary") If .AutoFilterMode = True Then .AutoFilterMode = False .Range("A3:E" & .Cells(Rows.Count, "A").End(xlUp).Row).AutoFilter Field:=1, Criteria1:=Key .Cells(1).CurrentRegion.Offset(, 1).Resize(, .Cells(1).CurrentRegion.Columns.Count - 1).Copy Sheets(dic(Key)).Cells(1) Sheets(dic(Key)).Activate ActiveWindow.DisplayGridlines = False ActiveSheet.Columns.AutoFit .AutoFilterMode = False .Activate End With Next End Sub
Yes, but it will depend on pattern that could be present in column B.
In simplest form...
=IFERROR(RIGHT(B4,4)-MID(B4,5,4)+1,"CHECK")
That'd require significant alteration in code logic. And will be more cumbersome if pattern changes for Column B. I'd recommend keeping the helper column.