Copy ranges from all worksheets and paste them in a new one

user_14780871 0
Viewed 83

Please help me, I need to copy different ranges until first blank cell from all the sheets and paste them in a new one. All in the same Workbook.

This is my attempt:

Sub Target()

   Dim lRow As Long
   Dim copyRange As Range
    Dim sh As Worksheet
    Dim shReport As Worksheet
    Set shReport = ThisWorkbook.Worksheets("Target")

    For Each sh In ThisWorkbook.Worksheets
        Select Case sh.Name
            Case Is <> "ALLProjectForReport"
                lRow = shReport.Cells(Rows.Count, "B").End(xlUp).Row
               Set copyRange = sh.Range("A3")

               copyRange.Copy Destination:=shReport.Range("B" & lRow)

        End Select
    Next
    Set shReport = Nothing
    Set sh = Nothing
End Sub
vba excel
2 Answers

Stack Parts of Columns (xlDown)

Option Explicit

Sub createReport()

    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim dst As Worksheet: Set dst = wb.Worksheets("Target")
    Dim cel As Range
    Set cel = dst.Cells(dst.Rows.Count, "B").End(xlUp).Offset(1)

    Dim src As Worksheet
    Dim rng As Range
    For Each src In wb.Worksheets
        Select Case src.Name
            Case "AllProjectForReport", "Target"
            Case Else
                With src.Range("A3")
                    Set rng = .End(xlDown)
                    If rng.Row < src.Rows.Count Then
                        Set rng = .Resize(rng.Row - .Row + 1)
                    Else
                        If Len(.Value) > 0 Then
                            Set rng = .Offset
                        Else
                            Set rng = Nothing
                        End If
                    End If
                    If Not rng Is Nothing Then
                        rng.Copy Destination:=cel
                        Set cel = cel.Offset(rng.Rows.Count)
                    End If
                End With
        End Select
    Next
  
    MsgBox "Report created.", vbInformation, "Success"

End Sub
user_98140690

This is not an easy one. Personally, before I start writing a macro, I write what I want the code to do as first thing, in small chunks. Then I give it a go with the programing.

Another suggestion, to avoid getting lost in the code, is to create descriptive variable names.

I'm very descriptive in this code, to help you understand better how it works. If you test it, remember to change the values in the CONFIG section of the macro.

Sub Copy_Paste_Target_Ranges()

Dim divya_sheet As Worksheet, ranges_last_col As String, col_paste As Long
Dim next_row As Long, ranges_first_row As String, ranges_first_col As String
Dim last_row As Long, target_range As String, new_sheet As String

'CONFIG
'----------------------
ranges_first_row = 10       'first row of the data sets
ranges_first_col = "e"      'first column of the data sets
ranges_last_col = "g"       'last column of the data sets
new_sheet = "New Sheet"     'name of the new sheet to create
col_paste = 2               'start pasting from this column number
'-----------------------

'create a new sheet
Sheets.Add
ActiveSheet.Name = new_sheet

'do a loop for all the sheets in this workbook
For Each divya_sheet In ThisWorkbook.Sheets

    'if divya_sheet is different from the new sheet proceed
    If divya_sheet.Name <> new_sheet Then

    With Sheets(divya_sheet.Name)

    'discover the last row of this data set before a blank cell
    last_row = _
    .Cells(ranges_first_row, ranges_first_col).End(xlDown).Row

    'create range
    target_range = _
    ranges_first_col & ranges_first_row & ":" & ranges_last_col & last_row

    'copy data in this range
    .Range(target_range).Copy

    'go to the last row of the sheet and then
    'search for the first occupied cell
    'starting from the bottom up. Sum one to get the next row number.
    next_row = _
    Sheets(new_sheet).Cells(Rows.Count, col_paste).End(xlUp).Row + 1

    'paste copied range
    Sheets(new_sheet).Cells(next_row, col_paste).PasteSpecial

    End With

    End If

Next divya_sheet

End Sub
user_148959850
Related