[VBA] Merge ไฟล์ Excel หลายไฟล์

พอดีมีเพื่อนตอนมธัยมทักมา เพื่อให้ช่วยรวมข้อมูลไฟล์ Excel หลายๆไฟล์ แต่ตอนนั้นผมเตรียมสอบ Toeic อยู่เลยปัดไป แต่จริงๆแอบเขียน VBA เพื่อรวมไฟล์ Excel หลายๆไฟล์ มารวมใน Sheet เดียว โดยมี Code คร่าวๆ ดังนี้
ถ้าว่างๆ เดี๋ยวมาอธิบาย Code นะ

Option Explicit
Public strPath      As String
Public Type SELECTINFO
    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

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 SELECTINFO) As Long
Function SelectFolder(Optional Msg) As String
    Dim sInfo       As SELECTINFO
    Dim path        As String
    Dim r           As Long, x As Long, pos As Integer
    sInfo.pidlRoot = 0&
    
    If IsMissing(Msg) Then
        sInfo.lpszTitle = "Select your folder."
    Else
        sInfo.lpszTitle = Msg
    End If
    
    sInfo.ulFlags = &H1
    
    x = SHBrowseForFolder(sInfo)
    
    path = Space$(512)
    r = SHGetPathFromIDList(ByVal x, ByVal path)
    If r Then
        pos = InStr(path, Chr$(0))
        SelectFolder = Left(path, pos - 1)
    Else
        SelectFolder = ""
    End If
End Function
'Merge all your excel files to a main file.
Sub MergeExcels()
    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 = 1        ' Row Number from where you wish to start copying
    
    ThisWB = ActiveWorkbook.Name
    
    path = SelectFolder("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), 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 "Files Merged!"
End Sub


Discover more from naiwaen@DebuggingSoft

Subscribe to get the latest posts sent to your email.