How copy data and insert Sheet name together

[marreco]

Hi, i try copy data in two tabs and tabname to summary sheet.

Sub InsertMySheetNameInColumn()
Dim ws  As Worksheet, LR1 As Long, LR2 As Long, LR3 As Long

Application.ScreenUpdating = False
    For Each ws In ActiveWorkbook.Worksheets
        If ws.Name <> "Summary" Then
            LR1 = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row + 1
            LR2 = ws.Range("A" & Rows.Count).End(xlUp).Row
            LR3 = ws.Range("N" & Rows.Count).End(xlUp).Row
            Worksheets("Summary").Range("E" & LR1).End(xlUp).Offset(1) = ws.Name
            ws.Range("A2:B" & LR2).Copy Destination:=Worksheets("Summary").Range("A" & LR1)
            ws.Range("N2:O" & LR3).Copy Destination:=Worksheets("Summary").Range("N" & LR1)
        End If
    Next ws
Application.ScreenUpdating = True
End Sub

 

[Marc L]

Hi, just a logic lack …​

Sub InsertMySheetNameInColumn()
    Dim Ws As Worksheet, LR As Long
    Application.ScreenUpdating = False
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> Plan3.Name Then
             LR = Plan3.Cells(1).CurrentRegion.Rows.Count + 1
        With Ws.Cells(1).CurrentRegion.Rows
            With .Item("2:" & .Count).Columns
                 .Item("A:B").Copy Plan3.Cells(LR, 1)
                 .Item("N:O").Copy Plan3.Cells(LR, 14)
            End With
                Plan3.Cells(LR, 5).Resize(.Count - 1).Value = Ws.Name
        End With
    End If
Next Ws
    Application.ScreenUpdating = True
End Sub

Do you like it ? So thanks to click on bottom right Like !
​

 

[Marc L]

To understand your issue, initial code updated
with bad or mod codelines in comment :​

Sub InsertMySheetNameInColumn()
'Dim ws  As Worksheet, LR1 As Long, LR2 As Long, LR3 As Long
Dim Ws As Worksheet, LR1 As Long, LR2 As Long
Application.ScreenUpdating = False
'  For Each Ws In ActiveWorkbook.Worksheets
    For Each Ws In ThisWorkbook.Worksheets
        If Ws.Name <> "Summary" Then
'          LR1 = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row + 1
            LR1 = ThisWorkbook.Worksheets("Summary").Range("A" & Rows.Count).End(xlUp).Row + 1
           LR2 = Ws.Range("A" & Rows.Count).End(xlUp).Row
'          LR3 = Ws.Range("N" & Rows.Count).End(xlUp).Row
'          Worksheets("Summary").Range("E" & LR1).End(xlUp).Offset(1) = Ws.Name
            ThisWorkbook.Worksheets("Summary").Range("E" & LR1).Resize(LR2 - 1).Value = Ws.Name
'          Ws.Range("A2:B" & LR2).Copy Destination:=Worksheets("Summary").Range("A" & LR1)
            Ws.Range("A2:B" & LR2).Copy ThisWorkbook.Worksheets("Summary").Range("A" & LR1)
'          Ws.Range("N2:O" & LR3).Copy Destination:=Worksheets("Summary").Range("N" & LR1)
            Ws.Range("N2:O" & LR2).Copy ThisWorkbook.Worksheets("Summary").Range("N" & LR1)
        End If
    Next Ws
Application.ScreenUpdating = True
End Sub

You may Like it !
​

 

[marreco]

Thank very much!!