日常开单送货VBA模块

合并数据

Sub 按钮1_Click()
送货单开单.Show
End SubPublic Sub hebing()
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

开单

Public Sub 合并送货单数据()
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))
Else
MsgBox "未选择文件夹"
End IfWb.Close False '关闭工作簿
End Sub
Public Sub 测试()
'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:=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 "新增错误，表名已存在", vbOKOnly, "提示"GoTo 100:
'                            rs1 = rs1 + 1End IfEnd If
100: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

并到一张excel

Sub 合并目录所有工作簿全部工作表()
On Error Resume Next
Dim MP, MN, AW, Wbn, wn
Dim Wb As Workbook
Dim i, a, b, d, c, e, last_row, ni
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
MP = "E:\杭实\汇报\公司汇报\资料\物联网1-10月工作时长\物联网1-10月工作时长" '工作簿路径
MN = Dir(MP & "\" & "*.xls") '工作簿路径
Set Newbook = Workbooks.Add
AW = ActiveWorkbook.Name
Num = 0
ni = 0
e = 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 = Dir
Loop
Newbook.SaveAs Filename:=MP & "\" & "考勤数据.xlsx"
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
End Sub

工作簿操作‘

Sub 合并目录所有工作簿全部工作表()
On Error Resume Next
Dim MP, MN, AW, Wbn, wn
Dim Wb As Workbook
Dim i, a, b, d, c, e, last_row, ni
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
MP = "E:\杭实\汇报\公司汇报\资料\物联网1-10月工作时长\物联网1-10月工作时长" '工作簿路径
MN = Dir(MP & "\" & "*.xlsx") '工作簿路径
Set Newbook = Workbooks.Add
AW = ActiveWorkbook.Name
Num = 0
ni = 0
e = 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 = ActiveWorkbook.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: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("C:C").ColumnWidth = 35 '列宽Wbn = Wbn & Chr(13) & Wb.NameWb.Close FalseEnd WithEnd If
MN = Dir
Loop
Newbook.SaveAs Filename:=MP & "\" & "进出库汇总3.xlsx"
Range("a1").Select
Application.ScreenUpdating = True
MsgBox "共合并了" & a & "个工作薄下全部工作表。如下：" & Chr(13) & Wbn, vbInformation, "提示"
End Sub

’遍历工作簿

Sub Ma()
mypath = "E:\杭实\财务\1-9月\"
myfile = Dir(mypath, vbDirectory)
a = 1
Do While myfile <> ""
If myfile <> "." And myfile <> ".." Then
Sheets("Sheet18").Cells(a, 1) = myfile
a = a + 1
myfile = Dir
Else
myfile = Dir
End If
Loop
End Sub

筛选模块


Public Sub 进出库筛选()
Dim k%
'On Error Resume Next
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
Name = "（安智）杭实物联网进出库汇总表 总"
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 IfWith 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 "2021/11/28" Thenk = 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 IfNextEnd With
NextThisWorkbook.Sheets("进出库").Range("A:L").RowHeight = 15 '行高
'    ThisWorkbook.Sheets("进出库").Range("C:C").ColumnWidth = 35 '列宽Wb.Close False '关闭工作簿End Sub
Public Sub 运输筛选()
Dim k%
On Error Resume Next
Application.ScreenUpdating = False
'MP = ActiveWorkbook.Path
Name = "脚手架运输台账（热联&安智）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.ValueIf Rng.Value Like "2021/11/29" Thenk = 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 IfNextEnd WithThisWorkbook.Sheets("运输").Range("A:L").RowHeight = 15 '行高
'         ThisWorkbook.Sheets("运输").Range("C:C").ColumnWidth = 35 '列宽'NextWb.Close False '关闭工作簿End Sub

日常开单送货VBA模块相关推荐

计算机中丢失vba,打开Excel的时候提示visual basic项目错误导致VBA模块代码丢失
有的时候,每当我们打开有VBA代码的Excel文件时,会看到提示,大概意思就是说"丢失了visual basic项目错误"的提示.结果,只能有只读的方式打开Excel.最后,Exc ...
EXCEL文件中的VBA模块名包含中文名导致打开失败的案例。
2019独角兽企业重金招聘Python工程师标准>>> 问题OFFICE版本:OFFICE 365 症状:打开带有中文VBA模块的时候,会提示如果选择"是",进 ...
日常一记(2)--vba修改模块名
系列文章目录文章目录系列文章目录前言一.问题描述二.解决方式总结前言一.问题描述二.解决方式在标记处修改即可!!! 总结分享: 成长过程,磕磕碰碰,难免有苦有泪,以后回味起来,心 ...
wps vba模块压缩包_01_创建第一个VBA小程序：你好，世界
大家好,我是一可赛二(Excel),EXCEL VBA爱好者,在这里分享我学习VBA的过程. 目录第一节什么是EXCEL VBA(宏) 第二节在EXCEL界面上调出"开发工具" ...
VBA模块， Word中有关定位选择后对选中的内容进行查找替换
Attribute VB_Name = "模块1" Sub 宏1() 单选多选判断 End Sub Sub 选择(s1 As String, s2 As String) Dim ...
VBA 模块级变量和过程级变量，全局变量，局部变量，end,exit end sub等影响
一个SUB内变量尽量要独立,因为所有变量都在sub生效 1.全局变量在整个工程文件内都有效: 2.静态全局变量只在定义它的文件内有效: 3.静态局部变量只在定义它的函数内有效,且程序仅分配一次内存,函 ...
wps VBA 更改模块的名字，VBA模块重命名，坑
使用的WPS,使用模块的时候想把名字修改了.网上查的结果的是http://www.excelpx.com/thread-79694-1-1.html 但是呢,我的就是没有属性这个框框,到群里问,大佬说 ...
日常使用------利用VbA对Excel中的多个sheet工作表排序
在excel工作簿中对有多个工作表,由于个人需要,对每个工作表中某一值的比较大小后,然后进行排序. 由于vba中字典对应值比较难以排序,所以就分为两步第一步是提取工作表名和对应字段写到工作表中: S ...
vba 定义类_VBA｜工程中的四类模块的具体含义与比较
新建一个工作簿后的VBE的工程资源管理器: 可以看到默认的3个工作表对应的模块和工作簿模块ThisWorkbook. 选择sheet1,点击"对象"列表下拉框: 可以看到一个可供选 ...

日常开单送货VBA模块

日常开单送货VBA模块相关推荐

最新文章

热门文章