VBA code to copy mutiple sets of data from one sheet into another

[dakvin]

Hello all,

I'm a new user to VBA. Have been programming since a week and I'm stuck with one of my code.


I have mutiple sheets contaning data in a certain format. I want to only copy few blocks of data from all the sheets and arrange in a certain order in a newly created worksheet. I'm successful in creating a sheet and copying the first range of data from all the sheets. However, my code fails for the other blocks of data ( other data ranges). Please find the attached code.

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook


On Error GoTo IfError


'1. Variables declaration
Dim Sht As Worksheet, DstSht As Worksheet
Dim LstRow As Long, LstCol As Long, DstRow As Long
Dim i As Integer, EnRange As String
Dim SrcRng1 As Range
Dim SrcRng2 As Range
Dim SrcRng3 As Range
Dim SrcRng4 As Range




'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With


'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
Application.DisplayAlerts = True


'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Consolidate_Data"
End With


'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = fn_LastRow(DstSht)
       
               
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = fn_LastColumn(Sht)
       EnRange1 = Sht.Cells(426, 3).Address
       
       EnRange2 = Sht.Cells(474, 351).Address
       EnRange3 = Sht.Cells(485, 351).Address
       EnRange4 = Sht.Cells(502, 351).Address
       
       Set SrcRng1 = Sht.Range("A77:" & EnRange1)
       MsgBox SrcRng1
       Set SrcRng2 = Sht.Range("A427:" & EnRange2)
      
       Set SrcRng3 = Sht.Range("A478:" & EnRange3)
       Set SrcRng4 = Sht.Range("A489:" & EnRange4)
    
       
       '5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        'If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
         '   MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
          '  GoTo IfError
        'End If
                
      '5.4: Copy data to the 'consolidated_data' WorkSheet
        SrcRng1.Copy Destination:=DstSht.Range("A" & DstRow + 1)
        LstCol2 = fn_LastColumn(Sht)
        MsgBox LstCol2
        SrcRng1.Copy Destination:=DstSht.Range("D" & DstRow + 1).PasteSpecial(Transpose:=True)
        LstCol = fn_LastColumn(Sht)
        SrcRng3.Copy Destination:=DstSht.Range("LstCol+1" & DstRow + 1)
        LstCol = fn_LastColumn(Sht)
        SrcRng4.Copy Destination:=DstSht.Range("LstCol+1" & DstRow + 1)
        
                
    End If


Next
DstSht.Range("A1") = "Dosing cycle Info"


IfError:


'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With


End Sub

Any suggestions and ideas would be really helpful.

 

[Fluff]

As you are making a number of function calls & haven't supplied the functions, this is a guess, but try

Sub Consolidate_Data_From_Different_Sheets_Into_Single_Sheet()
'Procedure to Consolidate all sheets in a workbook


On Error GoTo IfError


'1. Variables declaration
    Dim Sht As Worksheet, DstSht As Worksheet
    Dim LstRow As Long, LstCol As Long, DstRow As Long
    Dim i As Integer, EnRange As String
    Dim SrcRng1 As Range
    Dim SrcRng2 As Range
    Dim SrcRng3 As Range
    Dim SrcRng4 As Range




'2. Disable Screen Updating - stop screen flickering
'   And Disable Events to avoid inturupted dialogs / popups
'With Application
'    .ScreenUpdating = False
'    .EnableEvents = False
'End With


'3. Delete the Consolidate_Data WorkSheet if it exists
Application.DisplayAlerts = False
On Error Resume Next
ActiveWorkbook.Sheets("Consolidate_Data").Delete
On Error GoTo 0
Application.DisplayAlerts = True


'4. Add a new WorkSheet and name as 'Consolidate_Data'
With ActiveWorkbook
    Set DstSht = .Sheets.Add(After:=.Sheets(.Sheets.Count))
    DstSht.Name = "Consolidate_Data"
End With


'5. Loop through each WorkSheet in the workbook and copy the data to the 'Consolidate_Data' WorkSheet
For Each Sht In ActiveWorkbook.Worksheets
    If Sht.Name <> DstSht.Name Then
       '5.1: Find the last row on the 'Consolidate_Data' sheet
       DstRow = DstSht.Range("A" & Rows.Count).End(xlUp).Row
       
               
       '5.2: Find Input data range
       LstRow = fn_LastRow(Sht)
       LstCol = DstSht.Cells.Find("*", LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
       
       Set SrcRng1 = Sht.Range("A77:C426")
'       MsgBox SrcRng1
       Set SrcRng2 = Sht.Range("A427:MM474")
       Set SrcRng3 = Sht.Range("A478:MM485")
       Set SrcRng4 = Sht.Range("A489:MM502")
    
       
       '5.3: Check whether there are enough rows in the 'Consolidate_Data' Worksheet
        If DstRow + SrcRng.Rows.Count > DstSht.Rows.Count Then
            MsgBox "There are not enough rows to place the data in the Consolidate_Data worksheet."
            GoTo IfError
        End If
                
      '5.4: Copy data to the 'consolidated_data' WorkSheet
        SrcRng1.Copy Destination:=DstSht.Range("A" & DstRow + 1)
        SrcRng1.Copy
        DstSht.Range("D" & DstRow + 1).PasteSpecial Transpose:=True
       LstCol = fn_LastColumn(Sht)
        SrcRng3.Copy Destination:=DstSht.Cells(DstRow + 1, LstCol + 1)
       LstCol = fn_LastColumn(Sht)
        SrcRng4.Copy Destination:=DstSht.Cells(DstRow + 1, LstCol + 1)
        
                
    End If


Next
DstSht.Range("A1") = "Dosing cycle Info"

'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
Exit Sub
IfError:

    MsgBox "The macro encoutered an error & quit"
'6. Enable Screen Updating and Events
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With


End Sub