Help with VBA to copy and paste from sheets contained in a list

DAVID131
DAVID131 used Ask the Experts™
on
Hi
I am stuck trying to write code for a sequence of copy/paste values that requires reference to a list of worksheets.
The attached contains
1. The Admin sheet with a list of sheets that have to be referenced  (the number of sheets in the list changes weekly)
2. Sheets containing the data to be copied in H6:I? this list also changes weekly (sometimes there are blank cells)
3. Summary sheet where the copied values are pasted in C6:D? (the previous weeks list is cleared before the new data is brought across)

Any help would be appreciated
Test-1.xlsm
Comment
Watch Question

Do more with

Expert Office
EXPERT OFFICE® is a registered trademark of EXPERTS EXCHANGE®
View Solution Only
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
Hi David,

Please try this......
Sub CopyDataToSummary()
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
Application.ScreenUpdating = False
Set dws = Sheets("Summary")
Set admWs = Sheets("Admin")
dws.Cells.Clear
dws.Range("C5:D5").Value = Array("Code", "Sales")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 8 Then
   MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
   Exit Sub
End If
x = admWs.Range("B8:B" & alr).Value
For i = 1 To UBound(x, 1)
   On Error Resume Next
   Set ws = Sheets(x(i, 1))
   If Not ws Is Nothing Then
      lr = ws.Cells(Rows.Count, 8).End(xlUp).Row
      If lr > 5 Then
         ws.Range("H6:I" & lr).Copy dws.Range("C" & Rows.Count).End(3)(2)
      End If
   End If
Next i
Application.ScreenUpdating = True
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

Open in new window


If you have issue opening the attachment due to a temporary bug in the forum, please save it on your system before opening it otherwise just copy the above code on a standard module like Module1.
You may click the button on the Summary Sheet to run the code.
Test-1.xlsm
DAVID131

Author

Commented:
The rapid response is very much appreciated
The code works well
The only question is how do I get only the copied cells' values to be pasted as it currently brings across formulae
Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015
Commented:
Thanks for the feedback.
To copy only values, please try this.....
Sub CopyDataToSummary()
Dim ws As Worksheet, dws As Worksheet, admWs As Worksheet
Dim lr As Long, alr As Long, i As Long, dlr As Long
Dim x
Application.ScreenUpdating = False
Set dws = Sheets("Summary")
Set admWs = Sheets("Admin")
dws.Cells.Clear
dws.Range("C5:D5").Value = Array("Code", "Sales")
alr = admWs.Cells(Rows.Count, 2).End(xlUp).Row
If alr < 8 Then
   MsgBox "There are no sheets listed on Admin Sheet.", vbExclamation, "Sheet List Not Found!"
   Exit Sub
End If
x = admWs.Range("B8:B" & alr).Value
For i = 1 To UBound(x, 1)
   On Error Resume Next
   Set ws = Sheets(x(i, 1))
   If Not ws Is Nothing Then
      lr = ws.Cells(Rows.Count, 8).End(xlUp).Row
      If lr > 5 Then
         ws.Range("H6:I" & lr).Copy
         dws.Range("C" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
         Application.CutCopyMode = 0
      End If
   End If
Next i
dws.Range("C5").CurrentRegion.Borders.Color = vbBlack
Application.ScreenUpdating = True
MsgBox "Data has been copied to Summary Sheet successfully.", vbInformation, "Done!"
End Sub

Open in new window

Test-1.xlsm
DAVID131

Author

Commented:
Thank you very much
This is exactly matches my requirement
Subodh Tiwari (Neeraj)Excel & VBA Expert
Most Valuable Expert 2018
Awarded 2015

Commented:
You're welcome David! Glad to help.

Do more with

Expert Office
Submit tech questions to Ask the Experts™ at any time to receive solutions, advice, and new ideas from leading industry professionals.

Start 7-Day Free Trial