Excel中VBA合并工作表

时间初始化：

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_clearThisWorkbook.Sheets("送货单").Rows("2:" & last_row_clear).Delete
For Each sh In wb.WorksheetsIf Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" ThenDebug.Print sh.Namelr = 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 rngsIf Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置Debug.Print rsNext
100:sh.Range("B12:H" & rs).CopyThisWorkbook.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.NameElseEnd If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
MsgBox "已汇总完成", vbOKOnly, "提示"
Else
MsgBox "未选择文件夹"
End IfThisWorkbook.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") Thenrresponse = MsgBox("单号日期异常-非今天单据" & pddanhao & "，确认是否继续", vbOKCancel, "提示")If rresponse = vbOK ThenGoTo 100:ElseExit SubEnd 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.WorksheetsIf Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" And Trim(sh.Name) <> "出库台账" And Trim(sh.Name) <> "模板" ThenDebug.Print sh.NameIf Danhao = sh.Range("i4") Then '判断送货单号是否重复rresponse = MsgBox("送货单号重复", vbOKOnly, "送货单必须唯一") 'MsgBox("送货单号重复", vbYesNoCancel, "送货单必须唯一")Exit SubElseEnd IfEnd If
NextSet 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.CopyThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据ThisWorkbook.Worksheets(sname).Range("E4").Copy 'UsedRange.CopyThisWorkbook.Worksheets(sname).Range("E4").PasteSpecial Paste:=xlPasteValues '发货日期ThisWorkbook.Worksheets(sname).Range("G4").Copy 'UsedRange.CopyThisWorkbook.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 rngsIf Rng = "" Then rs = Rng.Row: GoTo 110 '获取空格行号位置Debug.Print rsNext
110:
'    判断单号是否重复Set rrngs = ThisWorkbook.Sheets("出库台账").Range("C4:C" & taizhanglr)    '确认列For Each Rrng In rrngsIf Rrng = ThisWorkbook.Sheets("开单").Range("i4") Then GoTo 111:
'        Debug.Print rsNextThisWorkbook.Sheets("开单").Range("C12:C" & rs).Copy 'UsedRange.CopyThisWorkbook.Worksheets("出库台账").Range("E" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '类别ThisWorkbook.Sheets("开单").Range("E12:E" & rs).Copy 'UsedRange.CopyThisWorkbook.Worksheets("出库台账").Range("F" & taizhanglr + 1).PasteSpecial Paste:=xlPasteValues '规格ThisWorkbook.Sheets("开单").Range("D12:D" & rs).Copy 'UsedRange.CopyThisWorkbook.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
ElseMsgBox "新增错误，表名已存在", vbOKOnly, "提示"
End If111:
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 ThenMP = fnameSet Wb = Workbooks.Open(MP) '打开文件For Each sh In Wb.WorksheetsIf Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" Thensname = sh.NameSet 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.CopyThisWorkbook.Worksheets(sname).Paste 'PasteSpecial Paste:=xlPasteValues '复制数据ThisWorkbook.Worksheets(sname).Range("A:j").RowHeight = 23 '行高rs = rs + 1 '统计表格述ElseMsgBox "新增错误，表名已存在" & sname, vbOKOnly, "提示"GoTo 0:End If
'                    On Error GoTo 0
0:Set ws = NothingEnd If
100:Debug.Print sh.NameNext 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 = TrueWb.Close False '关闭工作簿
End Sub

导入委托单

Private Sub CommandButton5_Click() '导入委托单
On Error Resume Next
Dim Danhao()
Dim rs As Integerfname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'判断文件是否存在
If fname <> False ThenMP = fname
ElseMsgBox "没有选中文件"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 rngsIf Rng = "" ThenGoTo 100 '获取空格行号位置Elsers = rs + 1
'            Debug.Print rsEnd IfNext
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 = Falserresponse = MsgBox("是否初始化", vbOKCancel, "提示")
If rresponse = vbOK ThenFor Each sh In ThisWorkbook.WorksheetsIf Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "开单" And Trim(sh.Name) <> "送货单" Thensh.DeleteEnd IfNext sh
ElseExit 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("开单").PrintPreviewEnd 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 9ThisWorkbook.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.WorksheetsIf sh.Name = shname ThenWith 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 WithEnd 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 Integerfname = Application.GetOpenFilename("Excel 文件 ,*.xls;*.xlsx")
'判断文件是否存在
If fname <> False ThenMP = fname
ElseMsgBox "没有选中文件"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).CopyEnd 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_clearThisWorkbook.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.WorksheetsIf Trim(sh.Name) <> "项目数据" And Trim(sh.Name) <> "模板" ThenDebug.Print sh.Namelr = 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 rngsIf Rng = "" Then rs = Rng.Row: GoTo 100 '获取空格行号位置Debug.Print rsNext
100:sh.Range("B12:H" & rs).CopyThisWorkbook.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.NameElseEnd If
Next
'aFile = Split(Filename, "\")
'sfilename = aFile(UBound(aFile))
wb.Close False '关闭工作簿Next iMsgBox "共计导入" & 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 ThenMP = fname
ElseMsgBox "没有选中文件"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 Iflast_row_clear = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row '最后一行位置Debug.Print "行数" & last_row_clearThisWorkbook.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.ValueIf Rng.Value Like Dtransport Thenk = 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 Thenlast_row = 4Elselast_row = ThisWorkbook.Sheets(sname).Cells(Rows.Count, 1).End(xlUp).Row  '最后一行位置End IfDebug.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 IfNextEnd With
NextThisWorkbook.Sheets(sname).Range("A:L").RowHeight = 15  '行高
'    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽Wb.Close False '关闭工作簿
MsgBox "已汇总完成", vbOKOnly, "提示"
ThisWorkbook.Worksheets(sname).ActivateEnd Sub

Excel中VBA合并工作表相关推荐

Excel中VBA操作工作表相关
VBA中已有工作簿合并表格数据 Sub 合并目录所有工作簿全部工作表() On Error Resume Next Dim MP, MN, AW, Wbn, wn Dim Wb As Workbook ...
将excel中的一个工作表按照某列拆分成多个sheet工作表
如何将excel中的一个工作表按照某列拆分成多个sheet工作表呢?接下来就利用VBA工具来解决这个问题. 拆分之前的工作表: 拆分之后的工作表: 操作步骤具体如下: 第一步:打开需要拆分的表格文件: ...
C#实战021:OleDb操作-新增Excel中的sheet工作表
获取到lExcel中的sheet中的所有工作表,我们就可以来创建新的sheet工作表了,首先我们判断下Excel中的sheet中的所有工作表中是否存在我们需要创建的sheet工作表,如果没有的话我们在 ...
vba工作表重命名_如何在Excel中重命名工作表选项卡
vba工作表重命名 By default, worksheet tabs in Excel are given generic names, such as Sheet1, Sheet2, and s ...
利用VBA批量删除EXCEL中的空白工作表SHEET
Sub delSheet()Dim x As WorksheetApplication.DisplayAlerts = FalseFor Each x In SheetsIf IsEmpty(x.Us ...
VBA——合并工作表及工作表单独保存的功能
沿用上一篇关于拆分excel工作表的文章的引子,本文分享下多个工作表合并的VBA功能.案例仍使用上篇文章的例子.已知有BS.HR等多个部门,分别存放在独立的以部门命名的工作表中,现需要将多个部门的工作 ...
EXCEL中如何获得工作表(sheet)的名称
excel 取得工作表名方法一常规方法 cell函数也可以这样取得工作表名,在任一单元格输入: =RIGHT(CELL("filename"),LEN(CELL(" ...
列注释_【EXCEL检查问题】：如何快速检查并删除EXCEL中隐藏的工作表、行、列等信息...
前注:本案例是以EXCEL2016为示范软件,各版本的部分功能和路径可能不同在EXCEL使用过程中,你是否遇到过某一列的公式怎么修改都报错的情况?你是否遇到过一个只有区区几行数据的表格,却占用了好几 ...
如何在Excel中批量新建工作表
任务需求: 按照月份时间生成单月工作表,生成结果如下图所示: 下面是具体的生成步骤,本文使用的是2016版Excel. 步骤一: 准备数据.在A1单元格设置类标签,在A2单元格输入2019年1月,然后 ...
Excel 中VBA 合并报表案例
今天财务小姐姐找到我,让我帮忙用VBA 写一个合并文件夹下的Excel 文件(*.xlsx 和 *.xls),方便她整理报表. 需求如下:所有源文件有三个sheet,其中第一个sheet 需要合并, ...

Excel中VBA合并工作表

Excel中VBA合并工作表相关推荐

最新文章

热门文章