Copy-Paste different cells from each worksheet to another worksheet (excluding some)

[NametobeRenamed]

Hello VBA Experts

I have a workbook which contains 50+ worksheets,

I want to copy Cells B1, K1 and L1 from each worksheet and paste it another worksheet ("OtherDatadump").

Also note that from this workbook few worksheets need to be excluded. These are with the names (Roles&Dropdowns, OtherDatadump, Summary, Consolidated Data, Project-SampleTemplate) in my workbook.

Can someone please help me?

I tried with below code, but this is not giving me desired results (For now I just tried to copy-paste cell K1).

Sub CopyPasteValuesFromAllWorkSheets()

  Dim ws As Worksheet
  Dim wb As Workbook
  Dim lastrow1 As Long, lastrow2 As Long
  
  Set wb = ThisWorkbook


  For Each ws In wb.Worksheets
       
     If ws.Name <> "Roles&Dropdowns" And ws.Name <> "OtherDatadump" And ws.Name <> "Summary" And ws.Name <> "Consolidated Data" And ws.Name <> "Project-SampleTemplate" Then
    
       ws.Range("K1").copy
       lastrow1 = ThisWorkbook.Sheets("OtherDatadump").Range("H" & Rows.Count).End(xlUp).Row
       ThisWorkbook.Sheets("OtherDatadump").Range("I2" & lastrow1).PasteSpecial Paste:=xlPasteValues
    
    End If

'NextIteration:
  Next ws

  Application.ScreenUpdating = True

  End Sub

[Marc L]

Hi,

as we do not have this workbook …

[TMS]

This

... .Range("I2" & lastrow1). ...

should probably be this

... .Range("I" & lastrow1). ...

But try this:

Sub CopyPasteValuesFromAllWorkSheets()

Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow1 As Long, lastrow2 As Long

Set wb = ThisWorkbook

Application.ScreenUpdating = False
For Each ws In wb.Worksheets
    If ws.Name <> "Roles&Dropdowns" And ws.Name <> "OtherDatadump" And ws.Name <> "Summary" And ws.Name <> "Consolidated Data" And ws.Name <> "Project-SampleTemplate" Then
        With wb.Sheets("OtherDatadump")
            lastrow1 = .Range("H" & .Rows.Count).End(xlUp).Row
            .Range("I" & lastrow1).Value = ws.Range("K1").Value
        End With
    End If
Next ws
Application.ScreenUpdating = True

End Sub

[TMS]

Note that you are using column H to determine the last row but writing to column I.

So, maybe it should be this:

            lastrow1 = .Range("I" & .Rows.Count).End(xlUp).Row
            .Range("I" & lastrow1 + 1).Value = ws.Range("K1").Value

[NametobeRenamed]

The code which was supplied not producing the desired results. I am attaching my workbook maybe this helps in debugging and producing the expected results.

I am attaching screenshot with final results, how the final result should look like. I request to please modify the code (or write a new code accordingly). Thanks in advance!!
Screenshot-9.PNG

[Marc L]

So why some worksheets are hidden, could the criteria be to include only visible worksheets after result worksheet ?

[NametobeRenamed]

Criteria or requirement for script is to exclude the worksheets which are with the names: Roles&Dropdowns, OtherDatadump, Summary, Consolidated Data, Project-SampleTemplate but include rest all others.

The reason for some sheets to be hidden is NOT to expose these to all users.

[Marc L]

According to post #5 attachment - missing in initial post ! - a starter VBA demonstration
to paste only to Sheet8 (OtherDatadump) worksheet module :

Sub Demo1()
        UsedRange.Offset(1).Rows.Delete
        Application.ScreenUpdating = False
    For S& = Index + 1 To Worksheets.Count
    With Worksheets(S)
        If .Visible = -1 Then Rows(UsedRange.Rows.Count)(2).Columns("C:F") = Application.Index(.[A1:K1], 1, Array(2, 11, 5, 7))
    End With
    Next
        UsedRange.Borders.Weight = 2
        Range("E2:E" & UsedRange.Rows.Count).NumberFormat = "mmm-yyyy_W"
        Application.ScreenUpdating = True
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[Marc L]

According to previous post a ThisWorkbook module VBA demonstration for starters :

Sub Demo2()
    Dim S$(), Ws As Worksheet
        S = Split("1 4 5 7 8")
   With Sheet8
       .UsedRange.Offset(1).Rows.Delete
    For Each Ws In Worksheets
     If IsError(Application.Match(Replace$(Ws.CodeName, "Sheet", ""), S, 0)) Then _
       .Rows(.UsedRange.Rows.Count)(2).Columns("C:F") = Application.Index(Ws.[A1:K1], 1, Array(2, 11, 5, 7))
    Next
       .UsedRange.Borders.Weight = 2
       .Range("E2:E" & .UsedRange.Rows.Count).NumberFormat = "mmm-yyyy_W"
   End With
End Sub 

► Do you like it ? ► ► So thanks to click on bottom left star icon « ★ Add Reputation » ! ◄ ◄

[TMS]

Try

Sub CopyPasteValuesFromAllWorkSheets()

Dim wb As Workbook
Dim ws As Worksheet
Dim lastrow1 As Long, lastrow2 As Long

Set wb = ThisWorkbook

Application.ScreenUpdating = False
For Each ws In wb.Worksheets
    If ws.Name <> "Roles&Dropdowns" And ws.Name <> "OtherDatadump" And ws.Name <> "Summary" And ws.Name <> "Consolidated Data" And ws.Name <> "Project-SampleTemplate" Then
        With wb.Sheets("OtherDatadump")
            lastrow1 = .Range("C" & .Rows.Count).End(xlUp).Row
            .Range("C" & lastrow1).Value = ws.Range("B1").Value
            .Range("D" & lastrow1).Value = ws.Range("K1").Value
            .Range("E" & lastrow1).Value = ws.Range("E1").Value
            .Range("F" & lastrow1).Value = ws.Range("G1").Value
        End With
    End If
Next ws
Application.ScreenUpdating = True

End Sub

[Marc L]

Hi TMS !

Logic error in your last VBA procedure, did you test it as it is ?

[TMS]

Hi Marc. Not tested at all. Looking at pictures, and playing with code on my iPad .

But please feel free to correct it on my behalf . . . I can’t see it

[Marc L]

Ok so post #10 correction :

Sub CopyPasteValuesFromAllWorkSheets()

'Dim wb As Workbook     ' useless !
Dim Ws As Worksheet
Dim lastrow1 As Long    ' useless -> , lastrow2 As Long

'Set wb = ThisWorkbook  ' useless !

Application.ScreenUpdating = False
With Sheet8
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "Roles&Dropdowns" And Ws.Name <> .Name And Ws.Name <> "Summary" And Ws.Name <> "Consolidated Data" And Ws.Name <> "Project-SampleTemplate" Then
         lastrow1 = .Range("C" & .Rows.Count).End(xlUp)(2).Row
        .Range("C" & lastrow1).Value = Ws.Range("B1").Value
        .Range("D" & lastrow1).Value = Ws.Range("K1").Value
        .Range("E" & lastrow1).Value = Ws.Range("E1").Value
        .Range("F" & lastrow1).Value = Ws.Range("G1").Value
    End If
Next Ws
End With
Application.ScreenUpdating = True

End Sub

According to efficiency in case of big data each result row should be written at once rather than cell by cell
so the post #10 VBA procedure revamped :

Sub CopyPasteValuesFromAllWorkSheets2()
    Dim LastRow As Long, Ws As Worksheet
        LastRow = 1
    With Sheet8
       .UsedRange.Offset(1).ClearContents
        Application.ScreenUpdating = False
    For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "Roles&Dropdowns" And Ws.Name <> .Name And Ws.Name <> "Summary" And _
       Ws.Name <> "Consolidated Data" And Ws.Name <> "Project-SampleTemplate" Then
        LastRow = LastRow + 1
       .Rows(LastRow).Columns("C:F") = Array(Ws.[B1], Ws.[K1], Ws.[E1], Ws.[G1])
    End If
    Next
    End With
        Application.ScreenUpdating = True
End Sub 

[NametobeRenamed]

Thank you Marc L and TMS very much and I really appreciate you time and efforts!!
I will be closing this loop.