Excel中VBA合并工作表

2023年1月2日 58次阅读 来源: 品尚公益团队

时间初始化：

ComboBox1.Text = "1"
'Dim checi(11)
For i = 1 To 10
'checi(i) = "第" & i & "车"
ComboBox1.AddItem (i)
Next i
'当前日期
Nt = DateAdd("d", -2, Now)
TextBox1.Text = Format(Nt, "yyyy/m/d")
'ComboBox1.List = checi 'Array("A", "B", "C", "D")
'ComboBox1.RowSource = checi 'Array("A", "B", "C", "D")
'CommandButton1.Enabled = True
'CommandButton2.Enabled = False
'CommandButton3.Enabled = False
'CommandButton4.Enabled = True
'CommandButton5.Enabled = False
'CommandButton6.Enabled = True
'CommandButton7.Enabled = False
'CommandButton8.Enabled = False
'CommandButton9.Enabled = False
'CommandButton10.Enabled = False
'ComboBox1.Enabled = False

合并送货单数据

Private Sub CommandButton1_Click() '开单汇总
Dim k%
Dim sh As Worksheet
On Error Resume Next
Application.ScreenUpdating = False
Filename = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
If Filename <> False Then
Debug.Print Filename
MP = Filename
'Name = "安智-送货单12.18"
'MP = "E:\杭实\运营数据\开单电子台账\" & Name & ".xlsx" '工作簿路径
 Set wb = Workbooks.Open(MP)
 
 '清空数据1
last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置
' Debug.Print "行数" & last_row_clear
 ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).Delete
For 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
            Next
100:
                    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 If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
MsgBox "已汇总完成", vbOKOnly, "提示"
Else
MsgBox "未选择文件夹"
End If

ThisWorkbook.Worksheets("送货单").Activate
wb.Close False '关闭工作簿
End Sub

新增工作表

Private Sub CommandButton3_Click() '新增
'Set Newbook = Workbooks.Add
Sname = ThisWorkbook.Sheets("开单").Range("C6").Value
ThisWorkbook.Sheets.Add after:=Sheets(ThisWorkbook.Worksheets.Count)
ThisWorkbook.Sheets.Add.Name = Sname
End Sub

判断是否重复、新增工作表

Private Sub CommandButton3_Click() '判断是否重复、新增工作表
On Error Resume Next
Application.ScreenUpdating = False
sname = ThisWorkbook.Sheets("开单").Range("C6").Value '文件名
Dim sh As Worksheet
'数据判断
Danhao = ThisWorkbook.Sheets("开单").Range("I4").Value '送货单号
'判断日期----
pddanhao = Trim(Mid(Danhao, 3, 8)) '判断日期
'Debug.Print pddanhao
'Debug.Print Format(Now, "yyyymmdd")
If pddanhao <> Format(Now, "yyyymmdd") Then
    rresponse = MsgBox("单号日期异常-非今天单据" & pddanhao & "，确认是否继续", vbOKCancel, "提示")
    If rresponse = vbOK Then
       GoTo 100:
    Else
        
        Exit Sub
    End If
End If
100:
'判断继续------

Xiangmu = ThisWorkbook.Sheets("开单").Range("C6").Value '项目名称
If Danhao = "" Then MsgBox "送货单号不能为空", vbOKOnly, "提示": Exit Sub
If Xiangmu = "" Then MsgBox "项目名称不能为空", vbOKOnly, "提示": Exit Sub


'新增工作表判断
For Each sh In ThisWorkbook.Worksheets
     If Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" And Trim(sh.Name) <> "出库台账" And Trim(sh.Name) <> "模板" Then
             Debug.Print sh.Name
              If Danhao = sh.Range("i4") Then '判断送货单号是否重复
              rresponse = MsgBox("送货单号重复", vbOKOnly, "送货单必须唯一") 'MsgBox("送货单号重复", vbYesNoCancel, "送货单必须唯一")
              Exit Sub
            Else
             End If
    End If
Next

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
  '复制数据
    ThisWorkbook.Sheets("开单").Range("A:K").Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据
     ThisWorkbook.Worksheets(sname).Range("E4").Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets(sname).Range("E4").PasteSpecial Paste:=xlPasteValues '发货日期
     ThisWorkbook.Worksheets(sname).Range("G4").Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets(sname).Range("G4").PasteSpecial Paste:=xlPasteValues '开单日期
    ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高
    
    
'    ---写入进出库台账----
    kaidanlr = ThisWorkbook.Sheets("开单").Cells(Rows.Count, "B").End(xlUp).Row '计算开单最后一行
    taizhanglr = ThisWorkbook.Sheets("出库台账").Cells(Rows.Count, "i").End(xlUp).Row '计算台账最后一行
    Debug.Print kaidanlr, taizhanglr
'    求空白单元格位置
        Set rngs = ThisWorkbook.Sheets("开单").Range("B11:B" & kaidanlr)   '确认列
        For Each Rng In rngs
        If Rng = "" Then rs = Rng.Row: GoTo 110 '获取空格行号位置
        Debug.Print rs
        Next
110:
'    判断单号是否重复
        Set rrngs = ThisWorkbook.Sheets("出库台账").Range("C4:C" & taizhanglr)    '确认列
        For Each Rrng In rrngs
        If Rrng = ThisWorkbook.Sheets("开单").Range("i4") Then GoTo 111:
'        Debug.Print rs
        Next

    ThisWorkbook.Sheets("开单").Range("C12:C" & rs).Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets("出库台账").Range("E" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '类别
    ThisWorkbook.Sheets("开单").Range("E12:E" & rs).Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets("出库台账").Range("F" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '规格
    ThisWorkbook.Sheets("开单").Range("D12:D" & rs).Copy 'UsedRange.Copy
    ThisWorkbook.Worksheets("出库台账").Range("G" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '规格

    ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "A").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("E4").Value '项目签收特别要求
    ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "B").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("G8").Value '车号
     ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "C").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("i4").Value  '车号
      ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "D").Resize(rs - 12, 1) = ThisWorkbook.Sheets("开单").Range("C5").Value '车号
    ThisWorkbook.Sheets("出库台账").Cells(taizhanglr + 1, "i").Resize(rs - 12, 1) = "出库"
    
    ThisWorkbook.Sheets("出库台账").Range("A:i").EntireColumn.AutoFit
Else
        MsgBox "新增错误，表名已存在", vbOKOnly, "提示"
End If







111:
Application.ScreenUpdating = True
Application.CutCopyMode = xlCopy
MsgBox "开单已新增", vbOKOnly, "提示"
ThisWorkbook.Worksheets("开单").Activate
End Sub

同步数据

Private Sub CommandButton4_Click() '同步数据
On Error Resume Next
'Dim rs1, rs
Application.ScreenUpdating = False
fname = 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:=ThisWorkbook.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 "新增错误，表名已存在" & sname, vbOKOnly, "提示"
                            GoTo 0:
                    End If
'                    On Error GoTo 0
0:
                Set ws = Nothing
            End If
100:
    Debug.Print sh.Name
    Next sh
End If
'    If rs1 >= 1 Then
'    MsgBox "同步完成|共计" & rs & "个开单表", vbOKOnly, "提示"
'    Else
'    MsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"
'    End If
MsgBox "同步完成|共计" & rs - 1 & "个开单表", vbOKOnly, "提示"
ThisWorkbook.Worksheets("开单").Activate
Application.ScreenUpdating = True
 Wb.Close False '关闭工作簿
End Sub

导入委托单

Private Sub CommandButton5_Click() '导入委托单
On Error Resume Next
Dim Danhao()
Dim rs As Integer

fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'判断文件是否存在
If fname <> False Then
    MP = fname
Else
    MsgBox "没有选中文件"
    Exit Sub
End If
MP = fname
Set wb = Workbooks.Open(MP) '打开文件
'复制数据
With ThisWorkbook.Worksheets("开单")
    '车次相关信息复制
    checi = 9 + Val(ComboBox1.Value)
    .Range("i4") = Replace(wb.Sheets("发货单").Range("B" & checi).Value, Chr(10), "") '计划单号
    .Range("C5") = Replace(wb.Sheets("发货单").Range("C" & checi).Value, Chr(10), "") '计划单号
    .Range("G8") = Replace(wb.Sheets("发货单").Range("H" & checi).Value, Chr(10), "") '运输车号
    .Range("C9") = Replace(wb.Sheets("发货单").Range("D" & checi).Value, Chr(10), "") '司机姓名
    .Range("G9") = Replace(wb.Sheets("发货单").Range("F" & checi).Value, Chr(10), "") '司机电话
'    wb.Sheets("发货单").Range("C" & checi).Copy  '计划单号
'    .Range("C5").PasteSpecial Paste:=xlPasteValues '复制数据
    
    '通用信息复制
    .Range("C6") = Trim(wb.Sheets("发货单").Range("C6").Value) '项目名称
    .Range("G6") = Trim(wb.Sheets("发货单").Range("E6").Value) & Trim(wb.Sheets("发货单").Range("F6").Value) '我司联系人
    .Range("C8") = Trim(wb.Sheets("发货单").Range("C8").Value) '收货地址
      .Range("C7") = Trim(wb.Sheets("发货单").Range("G18").Value) '客户单位
       .Range("G7") = Trim(wb.Sheets("发货单").Range("G6").Value) '客户签收人
    
End With
MsgBox "导入完成", vbOKOnly, "提示"

'判断有几车
 lr = wb.Sheets("发货单").Cells(Rows.Count, "B").End(xlUp).Row '获取最后一行
Set rngs = wb.Sheets("发货单").Range("B9:B" & lr) '确认列
    For Each Rng In rngs
        If Rng = "" Then
        GoTo 100 '获取空格行号位置
    Else
        rs = rs + 1
'            Debug.Print rs
    End If
    Next
100:
If rs > 2 Then MsgBox "共计" & rs - 1 & "车|已导入可忽略", vbOKOnly, "提示"


ThisWorkbook.Worksheets("开单").Activate
'ThisWorkbook.Worksheets("开单").Range("i4").PasteSpecial Paste:=xlPasteValues '复制数据
 wb.Close False '关闭工作簿
End Sub

表格初始化：

Private Sub CommandButton6_Click() '初始化表单
On Error Resume Next
Dim sh As Worksheet
Application.DisplayAlerts = False

rresponse = MsgBox("是否初始化", vbOKCancel, "提示")
If rresponse = vbOK Then
     For Each sh In ThisWorkbook.Worksheets
            If Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" Then
            sh.Delete
            End If
    Next sh
Else
    Exit Sub
End If
Application.DisplayAlerts = True
End Sub

combobox初始化

Private Sub UserForm_Initialize()
ComboBox1.Text = "第1车"
Dim checi(11)
For i = 1 To 10
'checi(i) = "第" & i & "车"
ComboBox1.AddItem ("第" & i & "车")
Next i
'ComboBox1.List = checi 'Array("A", "B", "C", "D")
'ComboBox1.RowSource = checi 'Array("A", "B", "C", "D")
End Sub

数据备份

Private Sub CommandButton7_Click() '数据备份
On Error Resume Next
Nname = Split(ActiveWorkbook.Name, ".")(0)
Application.Dialogs(xlDialogSaveAs).Show (Nname & Format(Now, "yyyymmdd"))
'
'MyFileName = Application.GetSaveAsFilename(InitialFileName:=Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx", fileFilter:="excel工作簿(*.xlsx),*.xlsx", Title:="数据备份")
'If MyFileName <> "False" Then
'ActiveWorkbook.SaveAs Filename:=MyFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
'End If
'Debug.Print ThisWorkbook.Path & "\" & Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx"

'ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & Nname & Format(Now, "yyyymmdd hhmmss") & ".xlsx"

MsgBox "数据已备份", vbOKOnly, "提示"
End Sub

设置打印

Private Sub CommandButton8_Click() '设置打印
'    Range("B2:E15").Select
'    ActiveSheet.PageSetup.PrintArea = "$B$2:$E$15"
'    Selection.PrintOut Copies:=1, Collate:=True
'    Range("G2:H14").Select
'    ActiveSheet.PageSetup.PrintArea = "$G$2:$H$14"
'    Selection.PrintOut Copies:=1, Collate:=True
'    Range("J15:K16").Select
'    ActiveSheet.PageSetup.PrintArea = "$J$15:$K$16"
'    Selection.PrintOut Copies:=1, Collate:=True
'    Range("L2:M14").Select

'Application.Dialogs(xlDialogPrint).Show
' '---设置打印区域
 Me.Hide
'    ActiveWindow.SelectedSheets.PrintPreview
lr = ThisWorkbook.Worksheets("开单").Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
ThisWorkbook.Worksheets("开单").PageSetup.PrintArea = "$A$1:$J$" & lr + 1
'    Selection.PrintOut Copies:=1, Collate:=True
ThisWorkbook.Worksheets("开单").PrintPreview

End Sub

清空数据

Private Sub CommandButton2_Click() '清空数据
'Debug.Print 9 + Val(ComboBox1.Value)
ThisWorkbook.Sheets("开单").Range("E4").Value = "=TODAY()" '文件名
ThisWorkbook.Sheets("开单").Range("G4").Value = "=E4" '文件名

ThisWorkbook.Sheets("开单").Range("I4").Value = "" '文件名
    For i = 5 To 9
    ThisWorkbook.Sheets("开单").Range("C" & i).Value = "" '文件名
    ThisWorkbook.Sheets("开单").Range("G" & i).Value = "" '项目名称
    Next i
        '--物料信息选择性粘贴--
        lr = ThisWorkbook.Sheets("模板").Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
        ThisWorkbook.Sheets("模板").Range("B12:i" & lr).Copy ThisWorkbook.Sheets("开单").Range("B12")

MsgBox "数据已清空", vbOKOnly, "提示"
ThisWorkbook.Worksheets("开单").Activate
End Sub

查询工作表

Private Sub CommandButton9_Click() '查询工作表
On Error Resume Next
Application.ScreenUpdating = False
shname = ThisWorkbook.Worksheets("开单").Range("C6").Value
If shname = "" Then
MsgBox "项目名称不能为空", vbOKOnly, "提示": Exit Sub
End If

'遍历工作簿中的工作表
For Each sh In ThisWorkbook.Worksheets
    If sh.Name = shname Then
        With ThisWorkbook.Worksheets("开单")
            sh.Range("B4:I4").Copy
            .Range("B4").PasteSpecial Paste:=xlPasteValues '基础数据选择性粘贴
             sh.Range("B5:C5").Copy
            .Range("B5").PasteSpecial Paste:=xlPasteValues '基础数据选择性粘贴
            '--订单信息选择性粘贴--
            sh.Range("C6:D9").Copy
            .Range("C6").PasteSpecial Paste:=xlPasteValues '订单信息选择性粘贴
            sh.Range("G6:i9").Copy
            .Range("G6").PasteSpecial Paste:=xlPasteValues '订单信息选择性粘贴
             '--物料信息选择性粘贴--
             lr = sh.Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
             sh.Range("B12:i" & lr).Copy .Range("B12")
             
             
        End With
    End If
Next sh
Application.CutCopyMode = xlCopy
MsgBox "项目名称：" & shname & ",查询完毕", vbOKOnly, "提示"
Application.ScreenUpdating = True
ThisWorkbook.Worksheets("开单").Activate
ThisWorkbook.Worksheets("开单").Range("G24").Select
End Sub

导入发货单

Private Sub CommandButton10_Click() '导入发货单
On Error Resume Next
Dim Danhao()
Dim rs As Integer

fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'判断文件是否存在
If fname <> False Then
    MP = fname
Else
    MsgBox "没有选中文件"
    Exit Sub
End If
MP = fname
Set wb = Workbooks.Open(MP) '打开文件
'复制数据
With ThisWorkbook.Worksheets("开单")
    '车次相关信息复制
     lr = wb.ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Row '计算最后一行
     wb.ActiveSheet.Range("B12:B" & lr).Copy
    .Range("D12").PasteSpecial Paste:=xlPasteValues '物料
     wb.ActiveSheet.Range("G12:G" & lr).Copy
    .Range("E12").PasteSpecial Paste:=xlPasteValues '规格
     wb.ActiveSheet.Range("C12:C" & lr).Copy
    .Range("C12").PasteSpecial Paste:=xlPasteValues '规格
    
'    Dim rngs
'    rngs = wb.ActiveSheet.Range("C12:C" & lr).Copy
    
End With
MsgBox "导入完成", vbOKOnly, "提示"

ThisWorkbook.Worksheets("开单").Activate
'ThisWorkbook.Worksheets("开单").Range("i4").PasteSpecial Paste:=xlPasteValues '复制数据
 wb.Close False '关闭工作簿
End Sub

批量合并

Private Sub CommandButton11_Click() '批量合并
On Error Resume Next
Dim strPath As String
Dim MyFileDialog As FileDialog
Dim SelectFiles As Variant
Application.ScreenUpdating = False
Set MyFileDialog = Application.FileDialog(msoFileDialogFolderPicker)
'显示打开文件对话框
Selectfnames = Application.GetOpenFilename("Excel 文件 (*.xl*)," & "*.xl*", , "打开", , True)
'fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'未选择
If TypeName(Selectfnames) = "Boolean" Then
'Debug.Print TypeName(SelectFiles)
Exit Sub
End If

 '清空数据1
last_row_clear = ThisWorkbook.Sheets("送货单").Cells(Rows.Count, "k").End(xlUp).Row '最后一行位置
' Debug.Print "行数" & last_row_clear
 ThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).Delete
'批量拷贝文件
For i = 1 To UBound(Selectfnames)
'Workbooks.Open SelectFiles(i)
'Debug.Print TypeName(SelectFiles)
Debug.Print Selectfnames(i)
Set wb = Workbooks.Open(Selectfnames(i))
 
For 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
            Next
100:
                    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 If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
wb.Close False '关闭工作簿

Next i

MsgBox "共计导入" & UBound(Selectfnames) & "堆场", vbOKOnly, "提示"
ThisWorkbook.Worksheets("送货单").Activate
Application.ScreenUpdating = True
'    If MyFileDialog.Show = -1 Then
'            '使用循环显示选取文件的路径和名称
'        For Each vrtSelectedItem In MyFileDialog.SelectedItems
'            strPath = vrtSelectedItem
'        Next
'    End If
'
'MsgBox strPath



'Dim fd As FileDialog ', vrtSelectedItem As Variant, iFile As Document
'    Set fd = Application.FileDialog(msoFileDialogFilePicker)
'    With fd
'        .AllowMultiSelect = True
'        .InitialFileName = ActiveDocument.Path
'        .Filters.Add "Word文档", "*.doc", 2
'        .FilterIndex = 2
'        If .Show <> -1 Then
'            MsgBox "您没有选择任何文档！", vbCritical
'            Exit Sub
'        Else
'            For Each vrtSelectedItem In .SelectedItems
'                Set iFile = Documents.Open(vrtSelectedItem)
'                iFile.Activate
''                Call 文档处理
'                Application.DisplayAlerts = False
'                iFile.Close True
'                Application.DisplayAlerts = False
''                MsgBox "Selected item's path: " & vrtSelectedItem
'            Next vrtSelectedItem
'        End If
'    End With
'    Set iFile = Nothing
'    Set fd = Nothing
'    MsgBox "ok"
End Sub

合并进出库台账：

Private Sub CommandButton12_Click() '批量合并进出库台账
On Error Resume Next
Dim Danhao()
Dim rs As Integer
Application.ScreenUpdating = False
fname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'判断文件是否存在
If fname <> False Then
    MP = fname
Else
    MsgBox "没有选中文件"
    Exit Sub
End If
MP = fname
Set Wb = Workbooks.Open(MP) '打开文件
'====批量合并===
Dim k%

 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
 '-----------
sname = "进出库台账"
Dtransport = TextBox1.Text '日期确认
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 ' +
End If

 last_row_clear = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置
 Debug.Print "行数" & last_row_clear
 ThisWorkbook.Sheets(sname).Rows("5:" & last_row_clear).Delete
'-----------
' For i = last_row_clear To 5 Step -1
'ThisWorkbook.Sheets("进出库").Rows(i).Delete
'Debug.Print "删除" & i & "行"
'Next
 '-----------
stockName = Array("总账（镇江库）", "总账（衢州库）", "总账（诸暨库）", "总账（昆山库）", "总账（泉州库）", "总账（武汉库）", "总账（泗阳库）", "总账（全椒库）")

Wb.Sheets(stockName(0)).Range("a1:Y3").Copy ThisWorkbook.Sheets(sname).Cells(1, 1)  '复制标题
For i = 0 To UBound(stockName)
''Debug.Print i
'        If i = 0 Then
'             Wb.Sheets(stockName(0)).Range("a1:Y3").Copy ThisWorkbook.Sheets(sname).Cells(1, 1)  '复制标题
''             ThisWorkbook.Sheets(sname).Cells(1, 1).Resize(3, 1) = 1
'             Else
'             GoTo 100:
'        End If
'100:
    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 Dtransport Then
                        k = k + 1 '记录条目
                        Debug.Print "条目" & k & "：" & Rng.Value & ActiveSheet.Name '输出当前工作表内容
                        
                        last_row = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row  '最后一行位置
                        If last_row < 4 Then
                        last_row = 4
                        Else
                        last_row = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row  '最后一行位置
                        End If
                        Debug.Print last_row
    '                       n = n + 1 '判断行数
                            ThisWorkbook.Sheets(sname).Cells(last_row, "a").Resize(2, 25) = Rng.EntireRow.Range("a1:y1").Value   '获取对应条目内容
                            ThisWorkbook.Sheets(sname).Cells(last_row, "z").Value = ActiveSheet.Name   '写入表格名称
                    End If
            Next
        End With
Next
    ThisWorkbook.Sheets(sname).Range("A:L").RowHeight = 15  '行高
'    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽
   Wb.Close False '关闭工作簿
MsgBox "已汇总完成", vbOKOnly, "提示"
ThisWorkbook.Worksheets(sname).Activate


End Sub

    原文作者：品尚公益团队
    原文地址: https://blog.csdn.net/u010719791/article/details/122210302
    本文转自网络文章，转载此文章仅为分享知识，如有侵权，请联系博主进行删除。
点赞