Excel 2016 VBA - Pull data from multiple sheets to One with specificities

[Noukon]

Hi everyone,

First of all, sorry for the request that has been asked multiple times on the internet on this subject; as a beginner in VBA, I try to learn by myself but it is not easy, and I find myself stucked and a little helpless!

I run an Excel file that contains several sheets:
- Sheet 1: destination sheet that centralizes all the data to be included in sheets 2, 3, 4, 5 and 6, with a header identical to all these same sheets, on 2 lines and 28 columns;
- Sheets 2, 3, 4, 5 and 6: source sheets whose data is entered manually in compliance with the header shared on 2 lines and 28 columns;
- Sheets 7, 8, 9 and 10: different data to exclude.

My goal is quite simple actually (I believe): automate via VBA the pulling of data from sheets 2, 3, 4, 5 and 6:
- From line 3 to the last entry and from column 1 to column 28;
- Integrate the data copied on sheet 1;
- Integrate in the query a "Clear" of sheet 1 without touching the Header (so clear of line 3-last line entered & column 1 to 28).

To do this, I used the following query, but it does not satisfy my needs (the completion of the criteria was certainly done in a bad way by myself): although the header seems preserved, the data is scattered and is not sticked in the right place, part of the header of the source files is being pulled... in short, it's barely functionning.

Here is the query:

Sub CopyFromMultiShts()    Dim wsMain As Worksheet    Dim wsExclude As Worksheet    Dim rngColHeaders As Range    Dim ws As Worksheet    Dim lngNextRow As Long    Dim cel As Range    Dim rngToFind As Range    Dim rngDestin As Range    Dim rngToCopy As Range    Set wsMain = Worksheets("Sheet1")     'Edit "Main data" to your output worksheet name    Set wsExclude = Worksheets("Sheet7")  'Edit "Exclude List" to worksheet with list of worksheets to exclude    Set wsExclude = Worksheets("Sheet8")    Set wsExclude = Worksheets("Sheet9")    Set wsExclude = Worksheets("Sheet10")    With wsMain        'Assign Column Headers of Main data sheet to a range variable        Set rngColHeaders = .Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))        '**************************************************************************************        Rows("3:" & Rows.Count).ClearContents    'Optional to clear existing data first.        '**************************************************************************************    End With    For Each ws In Worksheets   'Loop through worksheets        If WorksheetFunction.CountIf(wsExclude.Columns("A:A"), ws.Name) = 0 Then    'Equal zero then not in exclude list            lngNextRow = LastRowOrCol(True, wsMain.Cells) + 1 'Next blank row in Main data worksheet            With ws                'Assign column headers of source worksheet to a range variable                Set rngColHeaders = .Range(.Cells(1, 2), .Cells(1, .Columns.Count).End(xlToLeft))                For Each cel In rngColHeaders   'Loop through column headers in source worksheet                    If WorksheetFunction.CountA(cel.EntireColumn) > 1 Then   'If more than column header data exists                        With wsMain   'Start of nested With/End With                            'Search for column header in Main data worksheet                            Set rngToFind = .Rows(1).Find(What:=cel.Value, _                                            LookIn:=xlFormulas, _                                            LookAt:=xlWhole, _                                            SearchOrder:=xlByRows, _                                            SearchDirection:=xlNext, _                                            MatchCase:=False)                            If rngToFind Is Nothing Then GoTo SkipCopy  'If Nothing then column header not found so skip copy                            'Next blank row in Main data (lngNextRow from above) and column where column header found                            Set rngDestin = .Cells(lngNextRow, rngToFind.Column)                        End With        'End nested With/End With                        'Assign data from source worksheet to a range variable (From cell below column header to bottom of data)                        Set rngToCopy = .Range(cel.Offset(1, 3), .Cells(.Rows.Count, cel.Column).End(xlUp))                        'Copy column from source worksheet to Main data worksheet                        rngToCopy.Copy Destination:=rngDestin                    End IfSkipCopy:                Next cel            End With        End If    Next ws    wsMain.Columns.AutoFit    'Optional codeEnd SubFunction LastRowOrCol(bolRowOrCol As Boolean, Optional rng As Range) As Long    'Finds the last used row or column in a worksheet    'First parameter is True for Last Row or False for last Column    'Third parameter is optional        'Must be specified if not ActiveSheet    Dim lngRowCol As Long    Dim rngToFind As Range    If rng Is Nothing Then        Set rng = ActiveSheet.Cells    End If    If bolRowOrCol Then        lngRowCol = xlByRows    Else        lngRowCol = xlByColumns    End If    With rng        Set rngToFind = rng.Find(What:="*", _                LookIn:=xlFormulas, _                LookAt:=xlPart, _                SearchOrder:=lngRowCol, _                SearchDirection:=xlPrevious, _                MatchCase:=False)    End With    If Not rngToFind Is Nothing Then        If bolRowOrCol Then            LastRowOrCol = rngToFind.Row        Else            LastRowOrCol = rngToFind.Column        End If    End IfEnd Function

I obtained this query from the web; it can certainly be simplified or rewritten for my needs.
If anyone can suggest any points of improvement or simplification on this query, I'm interested

Thanks for your help!

 

[mumps]

Try:

Sub CopyData()
    Application.ScreenUpdating = False
    Dim desWS As Worksheet, x As Long
    Set desWS = Sheets(1)
    desWS.UsedRange.Offset(2).ClearContents
    For x = 2 To 6
        With desWS
            Sheets(x).UsedRange.Offset(2).Copy .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
        End With
    Next x
    Application.ScreenUpdating = True
End Sub

 

[Noukon]

Hey mumps,

Thanks a lot ! That did the work exactly the way I was expecting.
Glad I posted here ^^
Hope this will also help another person in the future.

Have a good day!

 

[mumps]

You are very welcome.