CODEWITHSUNDEEP
vbaexcel
Cylen
Cylen

Reputation: 119

Summary sheet created from multiple worksheets using a dynamic range

I have a 176 worksheets in a workbook, that all have the same format/structure, but are a difference size in row length.

I want to copy the data that is held in range A10:V(X) where X is a calculable number. This data will be pasted underneath each other, in columns B:W of the main sheet "RDBMergeSheet" and the name of the sheet that each row came from will be pasted into Column A of RDBMergeSheet so it can be seen which rows came from which sheets

X = (The lowest used row number in column J) - 3

If it makes it easier, another way to calculate X is find the row number in column A that contains the word "total" and subtract 1 from it.

The following link contains an example of such a sheet, with sanitised data.

https://i.sstatic.net/6zkDt.jpg

The code I've got so far, with help, is:

    Sub ImportData()

Dim x       As Long
Dim LR      As Long

Dim wks     As Worksheet

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With


Set wks = Sheets("RDBMergeSheet"): If Not wks Is Nothing Then wks.Delete
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"

For x = 1 To Worksheets.Count - 1
    LR = Application.Max(1, Sheets(x).Cells(Rows.Count, 10).End(xlUp).Row - 3)
    With wks.Cells(Rows.Count, 1)
        .Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
        .Offset(1).Resize(LR - 9).Value = Sheets(x).Name
    End With
Next x

wks.Select

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

Set wks = Nothing

End Sub

This errors out with a 1004: Application defined or object defined error on line 

.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value

If anyone has any ideas on either how to resolve this I would be extremely grateful.

Upvotes: 1

Views: 222

Answers (1)

Subodh Tiwari sktneer
Subodh Tiwari sktneer

Reputation: 9976

Please give this a try and tweak it as per your requirement to make sure the correct data is copied starting from the correct row on destination sheet.

Sub ImportData()
Dim LR As Long, dLR As Long, i As Long
Dim wks As Worksheet

With Application
    .Calculation = xlCalculationManual
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

On Error Resume Next
Set wks = Sheets("RDBMergeSheet")
wks.Cells.Clear
On Error GoTo 0

If wks Is Nothing Then
    Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
    wks.Name = "RDBMergeSheet"
End If

For i = 1 To Worksheets.Count - 1
    If Worksheets(i).Name <> wks.Name Then
        LR = Application.Max(1, Sheets(i).Cells(Rows.Count, 10).End(xlUp).Row - 3)
        If LR > 9 Then
            If wks.Range("B1").Value = "" Then
                dLR = 1
            Else
                dLR = wks.UsedRange.Rows.Count + 1
            End If
            wks.Range("B" & dLR & ":X" & LR - 9).Value = Worksheets(i).Range("B10:X" & LR).Value
            wks.Range("A" & dLR).Value = Worksheets(i).Name
        End If
    End If
Next i

On Error Resume Next
wks.Select
dLR = wks.UsedRange.Rows.Count
wks.Range("A1:A" & dLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"

wks.Range("A1:A" & dLR).Value = wks.Range("A1:A" & dLR).Value

With Application
    .Calculation = xlCalculationAutomatic
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
End With

Set wks = Nothing

End Sub

Upvotes: 2

Related Questions