• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Edit my Macros to Copy and paste cells on 3rd row of another sheet

Dear Everyone,

I have a spreadsheet with Macros that works fine. Only that instead of pasting on A2 of another sheet, I wanted to paste it on 3rd row of different sheets. Please see attachment.
Thank you.

Regards,
Michelle
 

Attachments

  • T5 ERSS Sheetpile Summary.xlsm
    30.6 KB · Views: 6
Last edited:
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
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 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
 
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


Dear Chihiro,

Thanks for editing the code it works great. But is it possible to paste it by overwriting the previous pasted cells when I update because it keeps on adding up as rows.

Regards,
Michelle
 
I'm bit busy today. Will look at it tomorrow.

Dear Chihiro,

Noted. Thank you. I actually got a code I got online. It's working but only title of row 1 is copied. What I want is the rows 1-3 to be copied as a title in multiple sheets. Please help how I can manage to do it with this code. Thanks. :)

Regards,
Michelle

Sub test()
Dim e
With Sheets("Sheet Piles Summary").Cells(1).CurrentRegion
.Parent.AutoFilterMode = False
For Each e In Filter(.Parent.[transpose(If(countif(offset(a4:a10000,,,row(1:10000)),a4:a10000)=1,a4:a10000,char(2)))], Chr(2), 0)
If Not IsSheetExists(e) Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = e
Sheets(e).Cells.Delete
.AutoFilter 1, e
.Copy Sheets(e).Cells(1)
.AutoFilter
Next
End With
End Sub


Function IsSheetExists(ByVal txt As String) As Boolean
On Error Resume Next
IsSheetExists = Len(Sheets(txt).Name)
On Error GoTo 0
End Function
 

Attachments

  • T5 ERSS Sheetpile Summary_2017-05-23xxx.xlsm
    32.5 KB · Views: 3
Hi Chihiro,

The below code also works only that it doesnt copy the 3rows of the title.
Thank you.

Regards,
Michelle


Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 10
Set ws = Sheets("Sheet Piles Summary")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "a2:j2"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter Field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move After:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
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")
 
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
 
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


Dear Chihiro,

Sorry for too much question. I have 2 more:

1. What if I just want to copy the B:E?
2. 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".

Regards,
Michelle
 
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

2. Is there a way to shorten my formula in column D?

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")

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".

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.
 
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.

Dear Chihiro,

Thank you so much for your clarification!

Cheers!
Michelle :)
 
Back
Top