Consulting

Results 1 to 3 of 3

Thread: Merge first sheet of multiple excel file

  1. #1

    Exclamation Merge first sheet of multiple excel file

    Hi!

    I would like to ask if someone can help me with this. this code should merge the first sheet of different workbook in to one. however, i notice that if my workbook has more than one sheet, I would get an error.
    Here's the part where the error is ..

    [VBA]Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))[/VBA]

    it say's says "Object variable or With block variable not set."


    Here's the whole code.

    [VBA]'Description: Combines all files in a folder to a master file.
    Option Explicit
    Public strPath As String
    Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
    End Type
    '32-bit API declarations
    Declare Function SHGetPathFromIDList Lib "shell32.dll" _
    Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
    Declare Function SHBrowseForFolder Lib "shell32.dll" _
    Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
    Function GetDirectory(Optional Msg) As String
    Dim bInfo As BROWSEINFO
    Dim path As String
    Dim r As Long, x As Long, pos As Integer
    ' Root folder = Desktop
    bInfo.pidlRoot = 0&
    ' Title in the dialog
    If IsMissing(Msg) Then
    bInfo.lpszTitle = "Select a folder."
    Else
    bInfo.lpszTitle = Msg
    End If
    ' Type of directory to return
    bInfo.ulFlags = &H1
    ' Display the dialog
    x = SHBrowseForFolder(bInfo)
    ' Parse the result
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
    pos = InStr(path, Chr$(0))
    GetDirectory = Left(path, pos - 1)
    Else
    GetDirectory = ""
    End If
    End Function
    Sub MergeFiles()
    Dim path As String, ThisWB As String, lngFilecounter As Long
    Dim wbDest As Workbook, shtDest As Worksheet, ws As Worksheet
    Dim Filename As String, Wkb As Workbook
    Dim CopyRng As Range, Dest As Range
    Dim RowofCopySheet As Integer
    RowofCopySheet = 2 ' Row to start on in the sheets you are copying from
    ThisWB = ActiveWorkbook.Name

    path = GetDirectory("Select a folder containing Excel files you want to merge")
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set shtDest = ActiveWorkbook.Sheets(1)
    Filename = Dir(path & "\*.xls", vbNormal)
    If Len(Filename) = 0 Then Exit Sub
    Do Until Filename = vbNullString
    If Not Filename = ThisWB Then
    Set Wkb = Workbooks.Open(Filename:=path & "\" & Filename)
    'Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1))
    ' Set CopyRng = Wkb.Sheets(1).Range(Cells(RowofCopySheet, 1), Cells(ActiveSheet.UsedRange.Rows.Count, ActiveSheet.UsedRange.Columns.Count))
    Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy Dest
    Wkb.Close False
    End If

    Filename = Dir()
    Loop
    Range("A1").Select

    Application.EnableEvents = True
    Application.ScreenUpdating = True

    MsgBox "Done!"
    End Sub[/VBA]
    I did not write this code. I got this from a forum. this is exaclty what i need. Except on the error that i stated above. I would appreciate any help. thanks!

  2. #2
    Knowledge Base Approver VBAX Wizard p45cal's Avatar
    Joined
    Oct 2005
    Location
    Surrey UK
    Posts
    5,876
    try (untested):
    [vba]Set Wkb = Workbooks.Open(Filename:=Path & "\" & Filename)
    With Wkb.Sheets(1)
    Set CopyRng = .Range(.Cells(RowofCopySheet, 1), .Cells(.UsedRange.Rows.Count, .UsedRange.Columns.Count))
    End With
    Set Dest = shtDest.Range("A" & shtDest.UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1)
    CopyRng.Copy Dest
    [/vba]
    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.

  3. #3
    tnx p45cal! i'll give it a try tomorrow at the office. hope it works

Posting Permissions

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