Transfer data from multiple worksheets to a summary

[dtsphil]

Good morning,

Have a review task to perform and I have created a worksheet template and a summary sheet. I have a macro that allows me to duplicate the worksheet as many times as I want. Once I have completed each worksheet, data is held in cells A93:F93. What I am looking for is a macro that transfers these values into the summary sheet cells D8:I8. So, the first worksheet values in A93:F93 will be transferred to cells D8:I8 in the summary sheet. The second worksheet values from A93:F93 need to go to the summary sheet D8:I8, but because the cells already have values, I need the macro to recognize that and offset to cells D9:I9....and so on and so on for the remaining worksheets. Thanks to all for reviewing this post.

 

[DanteAmor]

Try the following.
Change in the macro "Summary" by the name of your sheet.

Add in this line of the macro the sheets that should not be considered.
Case "Summary", "Sheet1"

Sub Transfer_data()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim i As Long
  
  Set sh1 = Sheets("Summary") 'Sheet name "Summary"
  i = 8
  sh1.Range("D8:I" & Rows.Count).ClearContents
  For Each sh In Sheets
    Select Case sh.Name
      Case "Summary", "Sheet1"  'Add here the sheets that should NOT be considered
      Case Else
        If WorksheetFunction.CountA(sh.Range("A93:F93")) > 0 Then
          sh1.Range("D" & i & ":I" & i).Value = sh.Range("A93:F93").Value
          i = i + 1
        End If
    End Select
  Next
End Sub

 

[dtsphil]

Try the following.
Change in the macro "Summary" by the name of your sheet.

Add in this line of the macro the sheets that should not be considered.
Case "Summary", "Sheet1"

Sub Transfer_data()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim i As Long
  
  Set sh1 = Sheets("Summary") 'Sheet name "Summary"
  i = 8
  sh1.Range("D8:I" & Rows.Count).ClearContents
  For Each sh In Sheets
    Select Case sh.Name
      Case "Summary", "Sheet1"  'Add here the sheets that should NOT be considered
      Case Else
        If WorksheetFunction.CountA(sh.Range("A93:F93")) > 0 Then
          sh1.Range("D" & i & ":I" & i).Value = sh.Range("A93:F93").Value
          i = i + 1
        End If
    End Select
  Next
End Sub

Thanks so much. I have spend so much time trying to learn and figure that out.......it works like a charm. This will save me so much time!!!!!!

 

[DanteAmor]

Im glad to help you, thanks for the feedback.