本文共 16206 字，大约阅读时间需要 54 分钟。

合并数据

Sub 按钮1_Click()送货单开单.ShowEnd SubPublic Sub hebing()Dim k%Dim sh As WorksheetOn Error Resume NextApplication.ScreenUpdating = FalseFilename = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")If Filename <> False ThenDebug.Print FilenameMP = Filename'Name = "安智-送货单12.18"'MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径 Set Wb = Workbooks.Open(MP)  '清空数据1last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置' Debug.Print "行数" & last_row_clear ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).DeleteFor Each sh In Wb.Worksheets    If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then    Debug.Print sh.Name       lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行       last_row = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "y").End(xlUp).Row            '获取行数            Set rngs = sh.Range("B11:B" & lr) '确认列            For Each Rng In rngs            If Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置            Debug.Print rs            Next100:                    sh.Range("B12:H" & rs).Copy                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "Q").PasteSpecial Paste:=xlPasteValues '复制数据                    wn = Wb.ActiveSheet.Name '获取表名                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "B").Resize(rs - 12, 1) = sh.Range("C4") '写入仓库编号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "C").Resize(rs - 12, 1) = sh.Range("E4") '写入发货日                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "D").Resize(rs - 12, 1) = sh.Range("G4") '写入开单日期                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "E").Resize(rs - 12, 1) = sh.Range("i4") '写入送货单号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "F").Resize(rs - 12, 1) = sh.Range("C5") '计划单号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "G").Resize(rs - 12, 1) = sh.Range("C6") '项目名称                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "H").Resize(rs - 12, 1) = sh.Range("G6") '我司联系人                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "I").Resize(rs - 12, 1) = sh.Range("C7") '客户单位                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "J").Resize(rs - 12, 1) = sh.Range("G7") '客户签收人                     ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "K").Resize(rs - 12, 1) = sh.Range("C8") '收货地址                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "l").Resize(rs - 12, 1) = sh.Range("G8") '运输车号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "M").Resize(rs - 12, 1) = sh.Range("C9") '司机姓名                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "n").Resize(rs - 12, 1) = sh.Range("G9") '联系电话                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "O").Resize(rs - 12, 1) = sh.Range("C10") '使用区域                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "p").Resize(rs - 12, 1) = sh.Range("G10") '项目签收特别要求                                        ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "y").Resize(rs - 12, 1) = sh.Name '写入表格名称                                     sh.Range("A:L").RowHeight = 12 '行高                    sh.Range("C:C").ColumnWidth = 5 '列宽                    Wbn = Wbn & Chr(13) & Wb.Name        Else                End IfNext'aFile = Split(Filename, "\")'sfilename = aFile(UBound(aFile))MsgBox "已汇总完成", vbOKOnly, "提示"ElseMsgBox "未选择文件夹"End IfThisWorkbook.Worksheets("送货单").ActivateWb.Close False '关闭工作簿End Sub

开单

Public Sub 合并送货单数据()Dim k%Dim sh As WorksheetOn Error Resume NextApplication.ScreenUpdating = FalseFilename = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")If Filename <> False ThenDebug.Print FilenameMP = Filename'Name = "安智-送货单12.18"'MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径 Set Wb = Workbooks.Open(MP)  '清空数据1last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置' Debug.Print "行数" & last_row_clear ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).DeleteFor Each sh In Wb.Worksheets    If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then    Debug.Print sh.Name       lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行       last_row = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "y").End(xlUp).Row            '获取行数            Set rngs = sh.Range("B11:B" & lr) '确认列            For Each Rng In rngs            If Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置            Debug.Print rs            Next100:                    sh.Range("B12:H" & rs).Copy                                        ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "Q").PasteSpecial Paste:=xlPasteValues '复制数据                    wn = Wb.ActiveSheet.Name '获取表名                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "B").Resize(rs - 12, 1) = sh.Range("C4") '写入仓库编号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "C").Resize(rs - 12, 1) = sh.Range("E4") '写入发货日                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "D").Resize(rs - 12, 1) = sh.Range("G4") '写入开单日期                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "E").Resize(rs - 12, 1) = sh.Range("i4") '写入送货单号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "F").Resize(rs - 12, 1) = sh.Range("C5") '计划单号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "G").Resize(rs - 12, 1) = sh.Range("C6") '项目名称                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "H").Resize(rs - 12, 1) = sh.Range("G6") '我司联系人                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "I").Resize(rs - 12, 1) = sh.Range("C7") '客户单位                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "J").Resize(rs - 12, 1) = sh.Range("G7") '客户签收人                     ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "K").Resize(rs - 12, 1) = sh.Range("C8") '收货地址                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "l").Resize(rs - 12, 1) = sh.Range("G8") '运输车号                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "M").Resize(rs - 12, 1) = sh.Range("C9") '司机姓名                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "n").Resize(rs - 12, 1) = sh.Range("G9") '联系电话                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "O").Resize(rs - 12, 1) = sh.Range("C10") '使用区域                    ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "p").Resize(rs - 12, 1) = sh.Range("G10") '项目签收特别要求                                        ThisWorkbook.Sheets("送货单").Cells(last_row + 1, "y").Resize(rs - 12, 1) = sh.Name '写入表格名称                                     sh.Range("A:L").RowHeight = 12 '行高                    sh.Range("C:C").ColumnWidth = 5 '列宽                    Wbn = Wbn & Chr(13) & Wb.Name        Else                End IfNext'aFile = Split(Filename, "\")'sfilename = aFile(UBound(aFile))ElseMsgBox "未选择文件夹"End IfWb.Close False '关闭工作簿End SubPublic Sub 测试()'On Error Resume Next'Dim rs1, rsApplication.ScreenUpdating = Falsefname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")If fname <> False Then    MP = fname    Set Wb = Workbooks.Open(MP) '打开文件    For Each sh In Wb.Worksheets        If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Then                sname = sh.Name                Set ws = ThisWorkbook.Worksheets(sname)                    If ws Is Nothing Then                         '新建工作表                          ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)                          ThisWorkbook.Sheets(ThisWorkbook.Worksheets.Count).Name = sname                      '复制数据                        Wb.Sheets(sh.Name).Range("A:K").Copy 'UsedRange.Copy                        ThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据                        ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高                        rs = rs + 1 '统计表格述                    Else                            MsgBox "新增错误，表名已存在", vbOKOnly, "提示"                            GoTo 100:'                            rs1 = rs1 + 1                    End If            End If100:    Next shEnd If'    If rs1 >= 1 Then'    MsgBox "同步完成|共计" & rs & "个开单表", vbOKOnly, "提示"'    Else'    MsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"'    End IfMsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"ThisWorkbook.Worksheets("开单").ActivateApplication.ScreenUpdating = TrueWb.Close False '关闭工作簿End Sub

并到一张excel

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 Then    ni = ni + 1 '判断导入表的顺序    Debug.Print "导入第" & ni & "表"    Set Wb = Workbooks.Open(MP & "\" & MN)    a = a + 1    '工作簿判断    'With Workbooks(1).ActiveSheet   With 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) '复制数据'                    Else                    Wb.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 & wn                e = e + c '累计行数                .Range("A:K").RowHeight = 12                .Range("C:C").ColumnWidth = 35                '.Cells(e + 1, "Z").Resize(c, 1) = MN & wn'            End If'        Next        Wbn = Wbn & Chr(13) & Wb.Name        Wb.Close False            End With    End If    MN = 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 & "\" & "*.xlsx") '工作簿路径Set Newbook = Workbooks.AddAW = ActiveWorkbook.NameNum = 0ni = 0e = 3 '标题栏数量Do While MN <> ""    If MN <> AW Then    ni = 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 = ActiveWorkbook.Name & Wb.ActiveSheet.Name'   With Newbook.Sheets("Sheet1") 'Workbooks(1).Sheets("Sheet4")    With Newbook.ActiveSheet                   d = 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&; "单表最后一行" & c                                last_row = .Cells(Rows.Count, 1).End(xlUp).Row '.Range("a1048576").End(xlUp).Row + 1 '最后一行位置                Debug.Print "终表最后一行" & last_row                 Wb.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 & wn                e = e + c '累计行数                 .Range("A:L").RowHeight = 12 '行高                                 .Range("C:C").ColumnWidth = 35 '列宽        Wbn = Wbn & Chr(13) & Wb.Name        Wb.Close False    End With     End IfMN = DirLoopNewbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"Range("a1").SelectApplication.ScreenUpdating = TrueMsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"End Sub

’遍历工作簿

Sub Ma()mypath = "E:\杭实\财务\1-9月\"myfile = Dir(mypath, vbDirectory)a = 1Do While myfile <> ""If myfile <> "." And myfile <> ".." ThenSheets("Sheet18").Cells(a, 1) = myfilea = a + 1myfile = DirElsemyfile = DirEnd IfLoopEnd Sub

筛选模块

Public Sub 进出库筛选()Dim k%'On Error Resume NextApplication.ScreenUpdating = False'MP = ActiveWorkbook.PathName = "（安智）杭实物联网进出库汇总表 总"MP = "C:\Users\HONORS\Desktop\" & Name & ".xlsx" '工作簿路径'MN = Dir(MP & "\" & "*.xlsx") '工作簿路径' Set Wb = Workbooks.Open(MP & "\" & MN) Set Wb = Workbooks.Open(MP)'-----------' For i = 1 To Wb.Sheets.Count'    'Cells(i, 1) = Sheets(i).Name'    Debug.Print Wb.Sheets(i).Name '获取表名'Next '-----------stockName = Array("总账（镇江库）", "总账（衢州库）", "总账（诸暨库）", "总账（昆山库）", "总账（泉州库）", "总账（武汉库）", "总账（泗阳库）", "总账（全椒库）")For i = 0 To UBound(stockName)Debug.Print i'        If i = 0 Then'             Wb.ActiveSheet.Range("a1:Y3").Copy ThisWorkbook.Sheets("测试").Cells(1, 1)  '复制标题'             ThisWorkbook.Sheets("测试").Cells(1, 1).Resize(3, 1) = 1'        End If    With Wb.Sheets(stockName(i))          Wb.Sheets(stockName(i)).Activate '当前工作表激活            lr = .Cells(Rows.Count, "A").End(xlUp).Row '获取最后一行            Set rngs = .Range("A1:A" & lr) '确认列            For Each Rng In rngs    '            Debug.Print Rng.Value                    If Rng.Value Like "2021/11/28" Then                        k = k + 1 '记录条目                        Debug.Print "条目" & k & "：" & Rng.Value & ActiveSheet.Name '输出当前工作表内容                        last_row = ThisWorkbook.Sheets("进出库").Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置    '                       n = n + 1 '判断行数                            ThisWorkbook.Sheets("进出库").Cells(last_row, "a").Resize(2, 25) = Rng.EntireRow.Range("a1:y1").Value  '获取对应条目内容                            ThisWorkbook.Sheets("进出库").Cells(last_row, "z").Value = ActiveSheet.Name  '写入表格名称                    End If            Next        End WithNext    ThisWorkbook.Sheets("进出库").Range("A:L").RowHeight = 15 '行高'    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽   Wb.Close False '关闭工作簿End SubPublic Sub 运输筛选()Dim k%On Error Resume NextApplication.ScreenUpdating = False'MP = ActiveWorkbook.PathName = "脚手架运输台账（热联&安智）12.1"MP = "C:\Users\HONORS\Desktop\" & Name & ".xlsx" '工作簿路径'MN = Dir(MP & "\" & "*.xlsx") '工作簿路径' Set Wb = Workbooks.Open(MP & "\" & MN) Set Wb = Workbooks.Open(MP)'-----------' For i = 1 To Wb.Sheets.Count'    'Cells(i, 1) = Sheets(i).Name'    Debug.Print Wb.Sheets(i).Name '获取表名'Next '-----------stockName = Array("热联")'For i = 0 To UBound(stockName)Debug.Print i'        If i = 0 Then接下来的货量，货量预计；    With Wb.ActiveSheet 'Wb.Sheets(stockName(0))'          Wb.Sheets(stockName(0)).Activate '当前工作表激活            lr = .Cells(Rows.Count, "A").End(xlUp).Row '获取最后一行            Set rngs = .Range("D1:D" & lr) '确认列            For Each Rng In rngs    '            Debug.Print Rng.Value                    If Rng.Value Like "2021/11/29" Then                        k = k + 1 '记录条目                        Debug.Print "条目" & k & "：" & Rng.Value & ActiveSheet.Name '输出当前工作表内容                        last_row = ThisWorkbook.Sheets("运输").Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置    '                       n = n + 1 '判断行数                            ThisWorkbook.Sheets("运输").Cells(last_row, "a").Resize(2, 147) = Rng.EntireRow.Range("a1:EQ1").Value  '获取对应条目内容                            ThisWorkbook.Sheets("运输").Cells(last_row, "ER").Value = ActiveSheet.Name  '写入表格名称                                        End If            Next        End With         ThisWorkbook.Sheets("运输").Range("A:L").RowHeight = 15 '行高'         ThisWorkbook.Sheets("运输").Range("C:C").ColumnWidth = 35 '列宽         'Next   Wb.Close False '关闭工作簿End Sub

转载地址：https://blog.csdn.net/u010719791/article/details/124459254 如侵犯您的版权，请留言回复原文章的地址，我们会给您删除此文章，给您带来不便请您谅解！