พอดีมีเพื่อนตอนมธัยมทักมา เพื่อให้ช่วยรวมข้อมูลไฟล์ 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.