Results 1 to 2 of 2

Thread: VBA merging a specific sheet to another workbook
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    New Member
    Join Date
    Jul 2017
    Posts
    4
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default VBA merging a specific sheet to another workbook

    Code:
    Option ExplicitPublic Sub CombineManyWorkbooksIntoOneWorksheet()
        
        Dim strDirContainingFiles As String, strFile As String, _
            strFilePath As String
        Dim wbkDst As Workbook, wbkSrc As Workbook
        Dim wksDst As Worksheet, wksSrc As Worksheet
        Dim lngIdx As Long, lngSrcLastRow As Long, _
            lngSrcLastCol As Long, lngDstLastRow As Long, _
            lngDstLastCol As Long, lngDstFirstFileRow As Long
        Dim rngSrc As Range, rngDst As Range, rngFile As Range
        Dim colFileNames As Collection
        Set colFileNames = New Collection
        
        'Set references up-front
        strDirContainingFiles = "C:\Users\Carl\Desktop\1234" '<~ your folder
        Set wbkDst = Workbooks.Add '<~ Dst is short for destination
        Set wksDst = wbkDst.ActiveSheet
        
        'Store all of the file names in a collection
        strFile = Dir(strDirContainingFiles & "\*.xlsx")
        Do While Len(strFile) > 0
            colFileNames.Add Item:=strFile
            strFile = Dir
        Loop
        
        ''CHECKPOINT: make sure colFileNames has the file names
        'Dim varDebug As Variant
        'For Each varDebug In colFileNames
        '    Debug.Print varDebug
        'Next varDebug
        
        'Now we can start looping through the "source" files
        'and copy their data to our destination sheet
        For lngIdx = 1 To colFileNames.Count
            
            'Assign the file path
            strFilePath = strDirContainingFiles & "\" & colFileNames(lngIdx)
            
            'Open the workbook and store a reference to the data sheet
            Set wbkSrc = Workbooks.Open(strFilePath)
            Set wksSrc = wbkSrc.Worksheets("2")
            
            'Identify the last row and last column, then
            'use that info to identify the full data range
            lngSrcLastRow = LastOccupiedRowNum(wksSrc)
            lngSrcLastCol = LastOccupiedColNum(wksSrc)
            With wksSrc
                Set rngSrc = .Range(.Cells(1, 1), .Cells(lngSrcLastRow, _
                                                         lngSrcLastCol))
            End With
            
            ''CHECKPOINT: make sure we have the full source data range
            'wksSrc.Range("A1").Select
            'rngSrc.Select
            
            'If this is the first (1st) loop, we want to keep
            'the header row from the source data, but if not then
            'we want to remove it
            If lngIdx <> 1 Then
                Set rngSrc = rngSrc.Offset(1, 0).Resize(rngSrc.Rows.Count - 1)
            End If
            
            ''CHECKPOINT: make sure that we remove the header row
            ''from the source range on every loop that is not
            ''the first one
            'wksSrc.Range("A1").Select
            'rngSrc.Select
            
            'Copy the source data to the destination sheet, aiming
            'for cell A1 on the first loop then one past the
            'last-occupied row in column A on each following loop
            If lngIdx = 1 Then
                lngDstLastRow = 1
                Set rngDst = wksDst.Cells(1, 1)
            Else
                lngDstLastRow = LastOccupiedRowNum(wksDst)
                Set rngDst = wksDst.Cells(lngDstLastRow + 1, 1)
            End If
            rngSrc.Copy Destination:=rngDst '<~ this is the copy / paste
            
            'Almost done! We want to add the source file info
            'for each of the data blocks to our destination
            
            'On the first loop, we need to add a "Source Filename" column
            If lngIdx = 1 Then
                lngDstLastCol = LastOccupiedColNum(wksDst)
                wksDst.Cells(1, lngDstLastCol + 1) = "Source Filename"
            End If
            
            'Identify the range that we need to write the source file
            'info to, then write the info
            With wksDst
            
                'The first row we need to write the file info to
                'is the same row where we did our initial paste to
                'the destination file
                lngDstFirstFileRow = lngDstLastRow + 1
                
                'Then, we need to find the NEW last row on the destination
                'sheet, which will be further down (since we pasted more
                'data in)
                lngDstLastRow = LastOccupiedRowNum(wksDst)
                lngDstLastCol = LastOccupiedColNum(wksDst)
                
                'With the info from above, we can create the range
                Set rngFile = .Range(.Cells(lngDstFirstFileRow, lngDstLastCol), _
                                     .Cells(lngDstLastRow, lngDstLastCol))
                                     
                ''CHECKPOINT: make sure we have correctly identified
                ''the range where our file names will go
                'wksDst.Range("A1").Select
                'rngFile.Select
                                     
                'Now that we have that range identified,
                'we write the file name
                rngFile.Value = wbkSrc.Name
                
            End With
            
            'Close the source workbook and repeat
            wbkSrc.Close SaveChanges:=False
            
        Next lngIdx
        
        'Let the user know that the combination is done!
        MsgBox "Data combined!"
        
    End Sub
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last row
    'OUTPUT      : Long, the last occupied row
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedRowNum(Sheet As Worksheet) As Long
        Dim lng As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                                  After:=.Range("A1"), _
                                  Lookat:=xlPart, _
                                  LookIn:=xlFormulas, _
                                  SearchOrder:=xlByRows, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False).Row
            End With
        Else
            lng = 1
        End If
        LastOccupiedRowNum = lng
    End Function
    
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    'INPUT       : Sheet, the worksheet we'll search to find the last column
    'OUTPUT      : Long, the last occupied column
    'SPECIAL CASE: if Sheet is empty, return 1
    Public Function LastOccupiedColNum(Sheet As Worksheet) As Long
        Dim lng As Long
        If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
            With Sheet
                lng = .Cells.Find(What:="*", _
                                  After:=.Range("A1"), _
                                  Lookat:=xlPart, _
                                  LookIn:=xlFormulas, _
                                  SearchOrder:=xlByColumns, _
                                  SearchDirection:=xlPrevious, _
                                  MatchCase:=False).Column
            End With
        Else
            lng = 1
        End If
        LastOccupiedColNum = lng
    End Function
    my problem is on
    Set wksSrc = wbkSrc.Worksheets("2")
    if the workbook doesnt have a sheet with name "2" it will stop looping until the last workbook, any one can solve it? and what if the worksheet have password? im still new and i need the program for my reports

    attached is the folder file of mine...
    1234.rar - 28 KB

  2. #2
    . MrExcel's Avatar
    Join Date
    Feb 2002
    Location
    Merritt Island Florida
    Posts
    873
    Post Thanks / Like
    Mentioned
    6 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA merging a specific sheet to another workbook

    It would help us if you can write a few sentences about what you are trying to do, rather than asking us to interpret 50+ lines of code to figure out what you want to do.

    It looks like you are reading through a series of workbook names. For each workbook in the list:
    Open each workbook
    Pull all of the data from the worksheet with a tab name of "2". That is what I infer from this line of code: Set wksSrc = wbkSrc.Worksheets("2")

    In plain English, what are you trying to do? Do you want to pull data from the second worksheet in each workbook? Then use
    Set wksSrc = wbkSrc.Worksheets(2)

    Let us know what you are trying to do and we can help.
    View a collection of recent Excel articles in the Excel Daily News

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

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