Consulting

Results 1 to 3 of 3

Thread: CONSOLIDATE 2 WORKBOOK INTO 1 MASTERSHEET

  1. #1
    VBAX Newbie
    Joined
    Jul 2018
    Posts
    4
    Location

    CONSOLIDATE 2 WORKBOOK INTO 1 MASTERSHEET

    Hihi,

    I have following code from somewhere and it works wonder on me.

    However,
    1. The macro copy header form every workbook. How should i restrict it to copy once only?
    2. How should I instruct VBA to paste value only without all the formula?
    3. Can macro sort the worksheet by column C?

    ANY help would be greatly appreciated!!

    Thanks

    Option Explicit
    
    Sub Consolidate()
    'Author:     Jerry Beaucaire'
    'Date:       9/15/2009     (2007 compatible)  (updated 4/29/2011)
    'Summary:    Merge files in a specific folder into one master sheet (stacked)
    '            Moves imported files into another folder
    
    
    Dim fName As String, fPath As String, fPathDone As String
    Dim LR As Long, NR As Long
    Dim wbData As Workbook, wsMaster As Worksheet
    
    
    'Setup
        Application.ScreenUpdating = False  'speed up macro execution
        Application.EnableEvents = False    'turn off other macros for now
        Application.DisplayAlerts = False   'turn off system messages for now
        
        Set wsMaster = ThisWorkbook.Sheets("Master")    'sheet report is built into
    
    
    With wsMaster
        If MsgBox("Clear the old data first?", vbYesNo) = vbYes Then
            .UsedRange.Offset(1).EntireRow.Clear
            NR = 2
        Else
            NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1    'appends data to existing data
        End If
    
    
    'Path and filename (edit this section to suit)
        fPath = "Z:\Shipping\Shipping Group\CHARLENE\TESTING\"          'THIS IS WHERE WE SAVE ALL THE WORKSHEET  'remember final \ in this string
        fPathDone = fPath & "Imported\"     'remember final \ in this string
        On Error Resume Next
            MkDir fPathDone                 'creates the completed folder if missing
        On Error GoTo 0
        fName = Dir(fPath & "*.xlsm*")       'listing of desired files, edit filter as desired
    
    
    'Import a sheet from found files
        Do While Len(fName) > 0
            If fName <> ThisWorkbook.Name Then              'don't reopen this file accidentally
                Set wbData = Workbooks.Open(fPath & fName)  'Open file
    
    
            'This is the section to customize, replace with your own action code as needed
                LR = Range("A" & Rows.Count).End(xlUp).Row  'Find last row
                Range("A1:z" & LR).EntireRow.Copy .Range("A" & NR)
                wbData.Close False                                'close file
                NR = .Range("A" & .Rows.Count).End(xlUp).Row + 1  'Next row
                Name fPath & fName As fPathDone & fName           'move file to IMPORTED folder
            End If
            fName = Dir                                       'ready next filename
        Loop
    End With
    
    
    ErrorExit:    'Cleanup
        ActiveSheet.Columns.AutoFit
        Application.DisplayAlerts = True         'turn system alerts back on
        Application.EnableEvents = True          'turn other macros back on
        Application.ScreenUpdating = True        'refreshes the screen
    End Sub
    Last edited by cyee; 07-05-2018 at 01:54 AM. Reason: ADD IN CODE

  2. #2
    VBAX Expert
    Joined
    Sep 2016
    Posts
    788
    Location
    If NR = 2 Then
        Range("A1:z" & LR).EntireRow.Copy
    Else
        Range("A2:z" & LR).EntireRow.Copy
    End If
    .Range("A" & NR).PasteSpecial xlPasteValues

    .Range("A2").CurrentRegion.Sort .Range("C2")

  3. #3
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    Try the follwing changes in this snippet:
    fName = Dir(fPath & "*.xlsm*")
    
    FR = 1 '<<<<<<<< added
    'Import a sheet from found files
    Do While Len(fName) > 0
      If fName <> ThisWorkbook.Name Then
        Set wbData = Workbooks.Open(fPath & fName)
    
        'This is the section to customize, replace with your own action code as needed
        LR = Range("A" & Rows.Count).End(xlUp).Row
        Range("A" & FR & ":z" & LR).EntireRow.Copy .Range("A" & NR) '<<<<<<<< changed
        FR = 2 '<<<<<<<< added
        wbData.Close False
    untested.
    p45cal
    Everyone: If I've helped and you can't be bothered to acknowledge it, I can't be bothered to look at further posts from you.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •