Copy specific cells from worksheets

seacrest

Active Member
Joined
Aug 15, 2002
Messages
301
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
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.

My Aswer Is This

Well-known Member
Joined
Jul 5, 2014
Messages
18,233
Office Version
  1. 2013
Platform
  1. Windows
Try this:
VBA Code:
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,302
Office Version
  1. 365
Platform
  1. Windows
My approach would be

VBA Code:
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

Well-known Member
Joined
Jul 5, 2014
Messages
18,233
Office Version
  1. 2013
Platform
  1. Windows
Or try this:
A little less code and a loop for the cells.
VBA Code:
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

Active Member
Joined
Aug 15, 2002
Messages
301

ADVERTISEMENT

Or try this:
A little less code and a loop for the cells.
VBA Code:
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

Well-known Member
Joined
Jul 5, 2014
Messages
18,233
Office Version
  1. 2013
Platform
  1. Windows
Try this:
VBA Code:
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

Active Member
Joined
Aug 15, 2002
Messages
301

ADVERTISEMENT

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

Well-known Member
Joined
Jul 5, 2014
Messages
18,233
Office Version
  1. 2013
Platform
  1. Windows
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

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
52,302
Office Version
  1. 365
Platform
  1. Windows
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'

VBA Code:
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
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,152,110
Messages
5,768,156
Members
425,458
Latest member
Jaspal1996

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top