VBA中已有工作簿合并表格数据
Sub 合并目录所有工作簿全部工作表()On Error Resume NextDim MP, MN, AW, Wbn, wnDim Wb As WorkbookDim i, a, b, d, c, e, last_row, niApplication.ScreenUpdating = FalseApplication.DisplayAlerts = False'--初始化Workbooks("台账自检.xlsm").Sheets("热联").DeleteWorkbooks("台账自检.xlsm").Sheets("明细").DeleteWorkbooks("台账自检.xlsm").Sheets("汇总").Range("A:M") = ""'--MP = ActiveWorkbook.Path '工作簿路径'MP = "C:\Users\HONORS\Desktop\结算小组数据检查" '工作簿路径MN = Dir(MP & "\" & "*.xlsx") '工作簿路径'Set Newbook = Workbooks.AddAW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量Do While MN <> ""If MN <> AW And MN <> MP & "台账自检.xlsm" Then '"C:\Users\HONORS\Desktop\结算小组数据检查\台账自检.xlsm"Debug.Print MNni = ni + 1 '判断导入表的顺序Debug.Print "导入第" & ni & "表"Set Wb = Workbooks.Open(MP & "\" & MN)a = a + 1'工作簿判断' Newbook.Sheets.Add After:=Newbook.Sheets(Newbook.Sheets.Count) '新建工作表' Newbook.Sheets.Add.Name = Wb.ActiveSheet.NameWorkbooks("台账自检.xlsm").Sheets.Add.Name = Wb.ActiveSheet.Name' With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")With Workbooks("台账自检.xlsm").ActiveSheet' With Newbook.ActiveSheetd = Wb.ActiveSheet.UsedRange.Columns.Count '判断列数c = Wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & clast_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置Debug.Print "终表最后一行" & last_rowWb.ActiveSheet.Range("a1:BP" & c).Copy .Cells(last_row + 1, 1) '复制数据wn = Wb.ActiveSheet.Name.Cells(4, "Z") = "表名".Cells(e + 1, "Z").Resize(c - 2, 1) = MN & wne = e + c '累计行数.Range("A:L").RowHeight = 12 '行高.Range("A:L").ColumnWidth = 10 '列宽Wbn = Wbn & Chr(13) & Wb.NameWb.Close False '关闭工作簿End WithEnd IfMN = DirLoop'--'Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"'复制数据With Workbooks("台账自检.xlsm").Sheets("汇总")'运输台账复制Workbooks("台账自检.xlsm").Sheets("热联").Range("C:C").Copy .Cells(1, "A")Workbooks("台账自检.xlsm").Sheets("热联").Range("D:D").Copy .Cells(1, "B")Workbooks("台账自检.xlsm").Sheets("热联").Range("H:H").Copy .Cells(1, "C")Workbooks("台账自检.xlsm").Sheets("热联").Range("o:o").Copy .Cells(1, "D")Workbooks("台账自检.xlsm").Sheets("热联").Range("p:p").Copy .Cells(1, "E")'工程台账复制Workbooks("台账自检.xlsm").Sheets("明细").Range("A:A").Copy .Cells(1, "h") '计划号Workbooks("台账自检.xlsm").Sheets("明细").Range("h:h").Copy .Cells(1, "i") '计划号Workbooks("台账自检.xlsm").Sheets("明细").Range("i:i").Copy .Cells(1, "j") '计划号Workbooks("台账自检.xlsm").Sheets("明细").Range("j:j").Copy .Cells(1, "k") '计划号Workbooks("台账自检.xlsm").Sheets("明细").Range("l:l").Copy .Cells(1, "k") '车牌号.Cells(2, "L").Value = "匹配"c = .Cells(Rows.Count, "j").End(xlUp).Row.Cells(3, "L").Resize(c, 1) = "=VLOOKUP(J3,A:E,3,FALSE)".Range("A:L").RowHeight = 12 '行高.Range("A:L").ColumnWidth = 12 '列宽.Range("A:L").Font.Size = 8 '字号.Range("A:L").Font.Name = "微软雅黑" '字体End WithWorkbooks("台账自检.xlsm").Sheets("汇总").ActivateWorkbooks("台账自检.xlsm").SaveRange("a1").SelectApplication.ScreenUpdating = TrueApplication.DisplayAlerts = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"End Sub
VBA中获取工作表名称
For i = 1 To Sheets.Count'Cells(i, 1) = Sheets(i).NameDebug.Print Sheets(i).NameNext
VBA操作Excel中盘点：
Sub 未盘点编码()Dim rng As Range, rngs As Range, k%For Each rng In [a1:a796]For Each rngs In [g1:g175]If rngs = rng ThenGoTo 100End IfNext rngsk = k + 1Cells(k, "h") = rng100:Next rngEnd Sub
VBA操作Excel中like运算符运用：
Sub aa()For j = 2 To 6For i = 2 To 14If Cells(i, "a") Like Cells(j, "e") Then n = n + 1NextRange("f" & j) = nn = 0NextEnd Sub
Excel合并单元格：
Option ExplicitPublic Sub 分类()Dim er%, rng%, rg As RangeApplication.DisplayAlerts = Falseer = Application.CountA(Sheets("住宿").[a:a])For rng = er To 2 Step -1Set rg = Sheets("住宿").Range("h" & rng)If rg = rg.Offset(-1) Then rg.Offset(-1).Resize(2).MergeNextApplication.DisplayAlerts = TrueDebug.Print er
excel中获取文件夹中的excel工作表名称：
Sub Ma()mypath = "E:\杭实\培训资料\初稿\"myfile = Dir(mypath, vbDirectory)a = 1Do While myfile <> ""If myfile <> "." And myfile <> ".." ThenSheets("备注").Cells(a, 1) = myfilea = a + 1myfile = DirElsemyfile = DirEnd IfLoopEnd Sub
合并工作簿：
Sub 合并目录所有工作簿全部工作表()On Error Resume NextDim MP, MN, AW, Wbn, wnDim Wb As WorkbookDim i, a, b, d, c, e, last_row, niApplication.ScreenUpdating = False'MP = ActiveWorkbook.PathMP = "C:\Users\HONORS\Desktop\进出库" '工作簿路径MN = Dir(MP & "\" & "*.xls") '工作簿路径Set Newbook = Workbooks.AddAW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量Do While MN <> ""If MN <> AW Thenni = ni + 1 '判断导入表的顺序Debug.Print "导入第" & ni & "表"Set Wb = Workbooks.Open(MP & "\" & MN)a = a + 1'工作簿判断'With Workbooks(1).ActiveSheetWith Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")' For i = 1 To Sheets.Count' If Sheets(i).Range("a1") <> "" Then'Wb.Sheets(i).Range("a4").Resize(1, Sheets(i).UsedRange.Columns.Count).Copy .Cells(1, 1)d = Wb.Sheets(1).UsedRange.Columns.Count '判断列数c = Wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & c'Wb.Sheets(i).Range("a2).Resize(c, d).Copy .Cells(.Range("a1048576").End(xlUp).Row + 1, 1)last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置Debug.Print "终表最后一行" & last_row'If ni = 1 Then'Wb.Sheets(1).Range("a1:Y4").Copy .Cells(1, 1) '复制数据'Wb.Sheets(1).Range("a5:Y" & c).Copy .Cells(4, 1) '复制数据'ElseWb.Sheets(1).Range("a1:Y" & c).Copy .Cells(last_row + 1, 1) '复制数据'End If'Wb.Sheets(1).Range("a3:Y" & c).Copy .Cells(1, 1) '复制到第一列wn = Wb.Sheets(1).Name.Cells(4, "Z") = "表名".Cells(e + 1, "Z").Resize(c - 2, 1) = MN & wne = e + c '累计行数'.Cells(e + 1, "Z").Resize(c, 1) = MN & wn' End If' NextWbn = Wbn & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMN = DirLoopNewbook.SaveAs Filename:=MP & "\" & "进出库汇总.xlsx"Range("a1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"End Sub
合并工作簿到一张表，汇总，
Sub 合并目录所有工作簿全部工作表()On Error Resume NextDim MP, MN, AW, Wbn, wnDim Wb As WorkbookDim i, a, b, d, c, e, last_row, niApplication.ScreenUpdating = False'MP = ActiveWorkbook.PathMP = "E:\杭实\汇报\公司汇报\资料\物联网1-10月工作时长\物联网1-10月工作时长" '工作簿路径MN = Dir(MP & "\" & "*.xls") '工作簿路径Set Newbook = Workbooks.AddAW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量Do While MN <> ""If MN <> AW Thenni = ni + 1 '判断导入表的顺序Debug.Print "导入第" & ni & "表"Set Wb = Workbooks.Open(MP & "\" & MN)a = a + 1'工作簿判断'With Workbooks(1).ActiveSheetWith Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")' For i = 1 To Sheets.Count' If Sheets(i).Range("a1") <> "" Then'Wb.Sheets(i).Range("a4").Resize(1, Sheets(i).UsedRange.Columns.Count).Copy .Cells(1, 1)d = Wb.Sheets(1).UsedRange.Columns.Count '判断列数c = Wb.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & c'Wb.Sheets(i).Range("a2).Resize(c, d).Copy .Cells(.Range("a1048576").End(xlUp).Row + 1, 1)last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置Debug.Print "终表最后一行" & last_row'If ni = 1 Then'Wb.Sheets(1).Range("a1:Y4").Copy .Cells(1, 1) '复制数据'Wb.Sheets(1).Range("a5:Y" & c).Copy .Cells(4, 1) '复制数据'ElseWb.Sheets(1).Range("a1:H" & c).Copy .Cells(last_row + 1, 1) '复制数据'End If'Wb.Sheets(1).Range("a3:Y" & c).Copy .Cells(1, 1) '复制到第一列wn = Wb.Sheets(1).Name.Cells(4, "K") = "表名".Cells(e + 1, "K").Resize(c - 2, 1) = MN & wne = e + c '累计行数.Range("A:K").RowHeight = 12.Range("C:C").ColumnWidth = 35'.Cells(e + 1, "Z").Resize(c, 1) = MN & wn' End If' NextWbn = Wbn & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMN = DirLoopNewbook.SaveAs Filename:=MP & "\" & "考勤数据.xlsx"Range("a1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"End Sub
合并工作簿，自定义工作表
Sub 合并目录所有工作簿全部工作表()On Error Resume NextDim MP, MN, AW, Wbn, wnDim Wb As WorkbookDim i, a, b, d, c, e, last_row, niApplication.ScreenUpdating = False'MP = ActiveWorkbook.PathMP = "E:\杭实\财务\1-9月" '工作簿路径MN = Dir(MP & "\" & "*.xlsx") '工作簿路径Set Newbook = Workbooks.AddAW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量Do While MN <> ""If MN <> AW Thenni = ni + 1 '判断导入表的顺序Debug.Print "导入第" & ni & "表"Set Wb = Workbooks.Open(MP & "\" & MN)a = a + 1'工作簿判断'With Workbooks(1).ActiveSheet' Newbook.Sheets.Add After:=Newbook.Sheets(Newbook.Sheets.Count) '新建工作表Newbook.Sheets.Add.Name = Wb.ActiveSheet.Name' With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")With Newbook.ActiveSheetd = Wb.ActiveSheet.UsedRange.Columns.Count '判断列数c = Wb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row 'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数Debug.Print Wb.Sheets(1).Name&; "单表最后一行" & clast_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置Debug.Print "终表最后一行" & last_rowWb.ActiveSheet.Range("a1:Y" & c).Copy .Cells(last_row + 1, 1) '复制数据wn = Wb.ActiveSheet.Name.Cells(4, "Z") = "表名".Cells(e + 1, "Z").Resize(c - 2, 1) = MN & wne = e + c '累计行数Wbn = Wbn & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMN = DirLoopNewbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"Range("a1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"End Sub
合并劳务劳动量
Public Sub 叉车()On Error Resume NextDim MP, MN, AW, Wbn, wnDim Wb As WorkbookDim i, a, b, d, c, e, last_row, niApplication.ScreenUpdating = FalseMP = "C:\Users\HONORS\Desktop\年度汇报\人效\10月" '工作簿路径MN = Dir(MP & "\" & "*.xlsx") '工作簿路径AW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量craftName = "叉车" '定义文件名last_row_clear = ThisWorkbook.Sheets(craftName).Cells(Rows.Count, "AJ").End(xlUp).Row '最后一行位置If last_row_clear >= 2 ThenThisWorkbook.Sheets(craftName).Rows("2:" & last_row_clear).DeleteEnd IfDo While MN <> ""If MN <> AW Thenni = ni + 1 '判断导入表的顺序Debug.Print "导入第" & ni & "表"Set Wb = Workbooks.Open(MP & "\" & MN)a = a + 1'工作簿判断' Newbook.Sheets.Add.Name = ActiveWorkbook.Name & Wb.ActiveSheet.NameWith ThisWorkbook.Sheets(craftName)d = Wb.Sheets(craftName).UsedRange.Columns.Count '判断列数c = Wb.Sheets(craftName).Cells(Rows.Count, "AJ").End(xlUp).Row 'Wb.Sheets(1).UsedRange.Rows.Count - 1 '判断行数Debug.Print d & "=" & cDebug.Print Wb.Sheets(craftName).Name&; "单表最后一行" & clast_row = .Cells(Rows.Count, "AJ").End(xlUp).Row '最后一行位置Debug.Print "终表最后一行" & last_rowWb.Sheets(craftName).Range("A1:AL" & c).Copy .Cells(last_row + 1, 1) '复制数据wn = Wb.Sheets(craftName).Name.Cells(4, "AM") = "表名".Cells(e + 1, "AM").Resize(c - 2, 1) = MN & wne = e + c '累计行数.Range("A:L").RowHeight = 12 '行高.Range("C:C").ColumnWidth = 35 '列宽Wbn = Wbn & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd IfMN = DirLoop'Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"Range("a1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"ThisWorkbook.Sheets(craftName).Range("A:AM").EntireColumn.AutoFitEnd Sub
