Copy specific cells from worksheets

[seacrest]

Hi, I need a macro that will copy cells from all worksheets that have the word "Parts" in D4
The cell values that need to be copied are
H16, H20, H24, H28, H32 ,H36.
The copied data then needs to be listed in a sheet called Partslist and the values listed from A5 down

 

[My Aswer Is This]

Try this:

Sub Check_For_Parts()
'Modified  12/24/2020  1:09:07 AM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Lastrow = 5
For i = 1 To Sheets.Count

With Sheets(i)
    If Sheets(i).Name <> "PartsList" Then
    If .Cells(4, 4).Value = "Parts" Then
        
        .Cells(16, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
        .Cells(20, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
        .Cells(24, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
        .Cells(28, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
        .Cells(32, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
        .Cells(36, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
    
    End If
    
    End If
End With
Next
Application.ScreenUpdating = True
End Sub

 

[Peter_SSs]

My approach would be

Sub CopyParts()
  Dim ws As Worksheet
  Dim nr As Long
  
  nr = 5
  For Each ws In Worksheets
    If ws.Name <> "Partslist" And ws.Range("D4").Value = "Parts" Then
      ws.Range("H16,H20,H24,H28,H32,H36").Copy Destination:=Sheets("Partslist").Range("A" & nr)
      nr = nr + 6
    End If
  Next ws
End Sub

Note that if any of those 6 cells on a 'Parts' sheet are blank then the code will copy those blanks to the Partslist sheet. If blanks are possible but you don't want them on Partslist then please post back with that information.

 

[My Aswer Is This]

Or try this:
A little less code and a loop for the cells.

Sub Check_For_Parts()
'Modified  12/24/2020  1:29:16 AM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Lastrow = 5
For i = 1 To Sheets.Count

With Sheets(i)
    If Sheets(i).Name <> "PartsList" Then
        If .Cells(4, 4).Value = "Parts" Then
        
            For b = 16 To 36 Step 4
                .Cells(b, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
            Next
        End If
    End If
End With
Next
Application.ScreenUpdating = True
End Sub

 

[seacrest]

Or try this:
A little less code and a loop for the cells.

Sub Check_For_Parts()
'Modified  12/24/2020  1:29:16 AM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Lastrow = 5
For i = 1 To Sheets.Count

With Sheets(i)
    If Sheets(i).Name <> "PartsList" Then
        If .Cells(4, 4).Value = "Parts" Then
       
            For b = 16 To 36 Step 4
                .Cells(b, "H").Copy Sheets("Partslist").Cells(Lastrow, 1): Lastrow = Lastrow + 1
            Next
        End If
    End If
End With
Next
Application.ScreenUpdating = True
End Sub

Can this copy be modified to copy values only and not formulas ? Sorry i wasn't very clear

 

[My Aswer Is This]

Try this:

Sub Check_For_Parts()
'Modified  12/24/2020  4:20:55 AM  EST
Application.ScreenUpdating = False
Dim i As Long
Dim b As Long
Dim Lastrow As Long
Lastrow = 5
For i = 1 To Sheets.Count

With Sheets(i)
    If Sheets(i).Name <> "PartsList" Then
        If .Cells(4, 4).Value = "Parts" Then
        
            For b = 16 To 36 Step 4
                .Cells(b, "H").Copy: Sheets("Partslist").Cells(Lastrow, 1).PasteSpecial xlPasteValues: Lastrow = Lastrow + 1
            Next
        End If
    End If
End With
Next
Application.CutCopyMode = False

Application.ScreenUpdating = True
End Sub

 

[seacrest]

Thank you for that, It worked perfectly. You noted in a previous post that blanks could be removed.
I would appreciate if you could modify your code to exclude blanks.


Thanks again.

 

[My Aswer Is This]

Thank you for that, It worked perfectly. You noted in a previous post that blanks could be removed.
I would appreciate if you could modify your code to exclude blanks.


Thanks again.

That was not me. That was another poster here. Maybe he can provide a solution.

 

[Peter_SSs]

As shown in my earlier code, there should be no need to treat the 6 cells on each relevant sheet individually as all 6 can all be transferred to the Partslist sheet at once.
This should transfer values only, leaving no blanks.
It assumes that there is nothing already in the range A5 and below in 'Partslist'

Sub CopyParts_v2()
  Dim ws As Worksheet
  Dim nr As Long
  
  With Sheets("Partslist")
    For Each ws In Worksheets
      If ws.Name <> "Partslist" And ws.Range("D4").Value = "Parts" Then
        nr = nr + 6
        .Range("A" & nr).Resize(6).Value = Application.Index(ws.Range("H:H"), Application.Transpose(Array(16, 20, 24, 28, 32, 36)), 1)
      End If
    Next ws
    .Range("A5", .Range("A" & Rows.Count).End(xlUp)).SpecialCells(xlBlanks).Delete shift:=xlUp
  End With
End Sub