alitrack.comAliTrack

Show Navigation Hide Navigation Home MADlib Software HTML Preview Add Question Question Archive QA Profile My Account VBA-快速合并多个Excel工作薄为一个工作薄 在知乎如何快速的合并多个 Excel 工作簿成为一个工作簿？答案的基础上添加了给sheet改名的功能 Function NameOfWorkbook(ByVal strFullPath As String) As String Dim FileNameFromPath FileNameFromPath = Right(strFullPath, Len(strFullPath) - InStrRev(strFullPath, "\")) NameOfWorkbook = Left(FileNameFromPath, (InStrRev(FileNameFromPath, ".", -1, vbTextCompare) - 1)) End Function Sub 工作薄间工作表合并() Dim FileOpen Dim X As Integer Dim WS As Worksheet Application.ScreenUpdating = False FileOpen = Application.GetOpenFilename(FileFilter:="Microsoft Excel文件(*.xls),*.xls", MultiSelect:=True, Title:="合并工作薄") X = 1 While X <= UBound(FileOpen) Workbooks.Open Filename:=FileOpen(X) For Each WS In sheets() WS.Name = NameOfWorkbook(FileOpen(X)) & "_" & WS.Name Next WS sheets().Move After:=ThisWorkbook.sheets(ThisWorkbook.sheets.Count) X = X + 1 Wend ExitHandler: Application.ScreenUpdating = True Exit Sub errhadler: MsgBox Err.Description End Sub 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 Function NameOfWorkbook ( ByVal strFullPath As String ) As String Dim FileNameFromPath FileNameFromPath = Right ( strFullPath , Len ( strFullPath ) - InStrRev ( strFullPath , "\")) NameOfWorkbook = Left(FileNameFromPath, (InStrRev(FileNameFromPath, " . ", -1, vbTextCompare) - 1)) End Function Sub 工作薄间工作表合并() Dim FileOpen Dim X As Integer Dim WS As Worksheet Application.ScreenUpdating = False FileOpen = Application.GetOpenFilename(FileFilter:=" Microsoft Excel 文件 ( * . xls ) , * . xls ", MultiSelect:=True, Title:=" 合并工作薄 ") X = 1 While X <= UBound(FileOpen) Workbooks.Open Filename:=FileOpen(X) For Each WS In sheets() WS.Name = NameOfWorkbook(FileOpen(X)) & " _ " & WS . Name Next WS sheets ( ) . Move After : = ThisWorkbook . sheets ( ThisWorkbook . sheets . Count ) X = X + 1 Wend ExitHandler : Application . ScreenUpdating = True Exit Sub errhadler : MsgBox Err . Description End Sub 如果你想多个sheet合并到一起，而不是追加sheet的话，请参考这篇百度经验， Option Explicit Sub mergeonexls() '合并多工作簿中指定工作表 On Error Resume Next Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet Dim t As Workbook, ts As Worksheet, l As Integer, h As Long Application.ScreenUpdating = False Application.DisplayAlerts = False x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _ Title:="Excel选择", MultiSelect:=True) Set t = ThisWorkbook Set ts = t.Sheets(1) '指定合并到的工作表，这里是第一张工作表 l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column For Each x1 In x If x1 <> False Then Set w = Workbooks.Open(x1) Set wsh = w.Sheets(1) '指定所需合并工作表，这里是第一张工作表 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then wsh.UsedRange.Copy ts.Cells(1, 1) Else wsh.UsedRange.Copy ts.Cells(h + 1, 1) End If w.Close End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub mergeeveryonexls() '将多个工作簿下的工作表依次对应合并到本工作簿下的工作表，即第一张工作表对应合并到第一张，第二张对应合并到第二张…… On Error Resume Next Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet Dim t As Workbook, ts As Worksheet, i As Integer, l As Integer, h As Long Application.ScreenUpdating = False Application.DisplayAlerts = False x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _ Title:="Excel选择", MultiSelect:=True) Set t = ThisWorkbook For Each x1 In x If x1 <> False Then Set w = Workbooks.Open(x1) For i = 1 To w.Sheets.Count If i > t.Sheets.Count Then t.Sheets.Add After:=t.Sheets(t.Sheets.Count) Set ts = t.Sheets(i) Set wsh = w.Sheets(i) l = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Column h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then wsh.UsedRange.Copy ts.Cells(1, 1) Else wsh.UsedRange.Copy ts.Cells(h + 1, 1) End If Next w.Close End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 Option Explicit Sub mergeonexls ( ) '合并多工作簿中指定工作表 On Error Resume Next Dim x As Variant, x1 As Variant, w As Workbook, wsh As Worksheet Dim t As Workbook, ts As Worksheet, l As Integer, h As Long Application.ScreenUpdating = False Application.DisplayAlerts = False x = Application.GetOpenFilename(FileFilter:="Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*", _ Title:="Excel选择", MultiSelect:=True) Set t = ThisWorkbook Set ts = t.Sheets(1) ' 指定合并到的工作表，这里是第一张工作表 l = ts . UsedRange . SpecialCells ( xlCellTypeLastCell ) . Column For Each x1 In x If x1 <> False Then Set w = Workbooks . Open ( x1 ) Set wsh = w . Sheets ( 1 ) '指定所需合并工作表，这里是第一张工作表 h = ts.UsedRange.SpecialCells(xlCellTypeLastCell).Row If l = 1 And h = 1 And ts.Cells(1, 1) = "" Then wsh.UsedRange.Copy ts.Cells(1, 1) Else wsh.UsedRange.Copy ts.Cells(h + 1, 1) End If w.Close End If Next Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub Sub mergeeveryonexls() ' 将多个工作簿下的工作表依次对应合并到本工作簿下的工作表，即第一张工作表对应合并到第一张，第二张对应合并到第二张…… On Error Resume Next Dim x As Variant , x1 As Variant , w As Workbook , wsh As Worksheet Dim t As Workbook , ts As Worksheet , i As Integer , l As Integer , h As Long Application . ScreenUpdating = False Application . DisplayAlerts = False x = Application . GetOpenFilename ( FileFilter : = "Excel文件 (*.xls; *.xlsx),*.xls; *.xlsx,所有文件(*.*),*.*" , _ Title : = "Excel选择" , MultiSelect : = True ) Set t = ThisWorkbook For Each x1 In x If x1 <> False Then Set w = Workbooks . Open ( x1 ) For i = 1 To w . Sheets . Count If i > t . Sheets . Count Then t . Sheets . Add After : = t . Sheets ( t . Sheets . Count ) Set ts = t . Sheets ( i ) Set wsh = w . Sheets ( i ) l = ts . UsedRange . SpecialCells ( xlCellTypeLastCell ) . Column h = ts . UsedRange . SpecialCells ( xlCellTypeLastCell ) . Row If l = 1 And h = 1 And ts . Cells ( 1 , 1 ) = "" Then wsh . UsedRange . Copy ts . Cells ( 1 , 1 ) Else wsh . UsedRange . Copy ts . Cells ( h + 1 , 1 ) End If Next w . Close End If Next Application . ScreenUpdating = True Application . DisplayAlerts = True End Sub alitrack January 22, 2017 Software Permalink readxl读取xls格式Excel可能出现数据混乱 R的readxl是个很棒的XLS和XLSX解析包，但最近发现它读取XLS（MicroSoft Excel 97-2003工作表）格式的时候，会出现数据混乱的情况，如果转为XLSX后则没有这个问题了，下面是找到的一个VBA，可以批量把XLS格式转为XLSX，方便readxl读取， Sub ChangeFileFormat() Dim strCurrentFileExt As String Dim strNewFileExt As String Dim objFSO As Object Dim objFolder As Object Dim objFile As Object Dim xlFile As Workbook Dim strNewName As String Dim strFolderPath As String strCurrentFileExt = ".xls" strNewFileExt = ".xlsx" strFolderPath = "C:\Users\Scorpio\Desktop\New folder" If Right(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath & "\" End If Set objFSO = CreateObject("Scripting.FileSystemObject") Set objFolder = objFSO.getfolder(strFolderPath) For Each objFile In objFolder.Files strNewName = objFile.Name If Right(strNewName, Len(strCurrentFileExt)) = strCurrentFileExt Then Set xlFile = Workbooks.Open(objFile.Path, , True) strNewName = Replace(strNewName, strCurrentFileExt, strNewFileExt) Application.DisplayAlerts = False Select Case strNewFileExt Case ".xlsx" xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbook Case ".xlsm" xlFile.SaveAs strFolderPath & strNewName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled End Select xlFile.Close Application.DisplayAlerts = True End If Next objFile ClearMemory: strCurrentFileExt = vbNullString strNewFileExt = vbNullString Set objFSO = Nothing Set objFolder = Nothing Set objFile = Nothing Set xlFile = Nothing strNewName = vbNullString strFolderPath = vbNullString End Sub 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 Sub ChangeFileFormat ( ) Dim strC...