按送货日期、客户名称、送货单号拆分送货单

jaxpqh · 发表于 2024-4-30 15:58

本帖最后由 jaxpqh 于 2024-5-2 14:18 编辑

　　我这里有一个名叫《送货单》的工作簿，里面有一个名叫《出货表》的工作表，我的需求是按送货日期、客户名、送货单号进行拆分。

　　1.VBA代码运行时，弹出对话框，要求手动输入要拆分的日期，默认日期为当日日期，如果是拆分当日日期的就不必输入，如果不是拆分当日日期的就手动修改为指定日期。

　　2.拆分后的工作簿保存到一个名叫《送货单》的文件夹，不同的客户拆分为不同的工作簿，工作簿命名为“客户名称+拆分日期”；同一客户名称不同送货单号拆分为不同工作表，放入同一工作簿，工作表名称命名为“客户名称+送货单号”。《送货单》文件夹内有我期望拆分后的样表。

　　3.同一日期如果运行代码拆分多次，那么后一次拆分的工作簿自动覆盖前一次拆分的工作簿。

　　4.运行代码不使用“模板”表格，直接新建工作簿工作表，即工作表以不同的送货单号循环建立，工作簿以不同的客户名称循环建立。

　　5.只要能拆分出相关内容即可，具体格式代码我可以自己弄。

　　诚恳期望得到大师的慷慨相助，在此先说声谢谢！

ykcbf1100 · 发表于 2024-4-30 16:30

先做个记号

limonet · 发表于 2024-4-30 16:52

关键字：into

limonet · 发表于 2024-4-30 16:53

Sub limonet()
Dim Cn As Object, StrSQL$, Arr As Variant, i%, j%, D As Date
D = Application.InputBox("请输入日期", , Date)
Set Cn = CreateObject("Adodb.Connection")
Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & ThisWorkbook.FullName
Arr = Cn.Execute("Select 客户名称,送货单号 From [出货表$] Where 送货日期=#" & D & "#  Group By 客户名称,送货单号").GetRows
ReDim Preserve Arr(0 To 1, 0 To UBound(Arr, 2) + 1)
For i = UBound(Arr, 2) - 1 To 0 Step -1
      If i = UBound(Arr, 2) - 1 Or Arr(0, i) <> Arr(0, i + 1) Then
         Cn.Close: Cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0 XML;Data Source=" & ThisWorkbook.Path & "\送货单\" & Arr(0, i) & D & ".xlsx"
      End If
      StrSQL = "Select * Into [" & Arr(0, i) & Arr(1, i) & "] From [Excel 12.0;DataBase=" & ThisWorkbook.FullName & "].[出货表$] Where 客户名称='" & Arr(0, i) & "' And 送货单号=" & Arr(1, i)
      Cn.Execute (StrSQL)
Next i
End Sub

DAY18883320729 · 发表于 2024-4-30 17:00

这个蛮有意思的，跟我写的那个拆分差不多；

ykcbf1100 · 发表于 2024-4-30 19:39

本帖最后由 ykcbf1100 于 2024-4-30 19:40 编辑

附件供参考。。。

ykcbf1100 · 发表于 2024-4-30 19:41

本帖最后由 ykcbf1100 于 2024-4-30 20:13 编辑

参与一下。。。

Sub ykcbf() '//2024.4.30
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("Scripting.Dictionary")
Set ws = ThisWorkbook
p = ws.Path & "\送货单"
If Dir(p, vbDirectory) = "" Then MkDir p
Set sh = ws.Sheets("出货表")
today = Format(CDate(Date), "yyyy/m/d")
rq = Application.InputBox("请输入日期：", "日期输入", today)
bt = 1 '//标题行数
col = 3
With sh
r = .Cells(Rows.Count, col).End(3).Row
arr = .[a1].Resize(r, 12)
End With
For i = bt + 1 To UBound(arr)
If DateValue(arr(i, 2)) = DateValue(rq) Then
s = arr(i, col): ss = arr(i, 1)
If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
d(s)(ss)(i) = i
End If
Next
On Error Resume Next
For Each k In d.keys
Application.SheetsInNewWorkbook = d(k).Count
Set wb = Workbooks.Add
n = 0
For Each kk In d(k).keys
If kk <> Empty Then
n = n + 1
Set sht = wb.Sheets(n)
ws.Sheets("模板").Cells.Copy sht.[a1]
m = 0: Sum = 0
ReDim brr(1 To 10, 1 To 6)
With sht
.Name = k & kk
.[a2] = "　　送货单号：" & kk
.[a3] = "　　客户名称：" & k
.[e2] = "送单日期：" & Format(rq, "yyyy年m月d日")
.[E3] = "制单日期：" & Format(Date, "yyyy年m月d日")
For Each kkk In d(k)(kk).keys
m = m + 1
For j = 4 To 8
brr(m, j - 3) = arr(kkk, j)
Sum = Sum + brr(m, 5)
Next
brr(m, 6) = arr(kkk, 12)
Next
.[b5].Resize(m, 6) = brr
.Cells(13, "f") = Sum
End With
End If
Next
wb.SaveAs p & k & "(" & Format(rq, "yyyy年m月d日") & "）"
wb.Close 1
Next
Set d = Nothing
Application.ScreenUpdating = True
MsgBox "拆分完毕！"
End Sub

复制代码

ooluckydog · 发表于 2024-4-30 20:30

长度不够不让发

jaxpqh · 发表于 2024-4-30 21:17

本帖最后由 jaxpqh 于 2024-4-30 21:18 编辑

ykcbf1100 发表于 2024-4-30 19:41
参与一下。。。

　　谢谢您的无私帮助，有一个需求（如下图）您可能没注意到。恳求您改一改代码，满足我这个需求。谢谢您了！

chxw68 · 发表于 2024-4-30 22:12

Sub test()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
lk = Array(4, 32, 6, 8.13, 5.88, 10, 17)
rq0 = Application.InputBox(prompt:="请输入送货日期(格式为:yyyymmdd)", Title:="操作提示", Default:=Format(Date, "yyyymmdd"), Type:=2)
If Not IsDate(Format(rq0, "0000-00-00")) Then
MsgBox "非规日期！"
Exit Sub
End If
rq = CDate(Format(rq0, "0000-00-00"))
If Dir(ThisWorkbook.Path & "\送货单", vbDirectory) = "" Then
MkDir ThisWorkbook.Path & "\送货单"
End If
With ThisWorkbook.Worksheets("出货表")
.AutoFilterMode = False
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:l" & r)
End With
For i = 1 To UBound(arr)
If arr(i, 2) = rq Then
If Not d.exists(arr(i, 3)) Then
Set d(arr(i, 3)) = CreateObject("scripting.dictionary")
End If
If Not d(arr(i, 3)).exists(arr(i, 1)) Then
Set d(arr(i, 3))(arr(i, 1)) = CreateObject("scripting.dictionary")
End If
d(arr(i, 3))(arr(i, 1))(i) = Empty
End If
Next
For Each aa In d.keys
Application.SheetsInNewWorkbook = d(aa).Count
Set wb = Workbooks.Add
p = 0
With wb
For Each bb In d(aa).keys
p = p + 1
With .Worksheets(p)
.Name = aa & bb
ReDim brr(1 To d(aa)(bb).Count, 1 To 7)
M = 0
For Each cc In d(aa)(bb).keys
M = M + 1
brr(M, 1) = M
brr(M, 2) = arr(cc, 4)
brr(M, 3) = arr(cc, 5)
brr(M, 4) = arr(cc, 6)
brr(M, 5) = arr(cc, 7)
brr(M, 6) = arr(cc, 8)
brr(M, 7) = arr(cc, 12)
Next
With .Range("a1")
.Value = "送货单"
.Resize(1, 7).Merge
With .Font
.Name = "Times New Roman"
.Size = 20
End With
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
.Rows(1).RowHeight = 45
With .Range("a2")
.Value = " 送货单号：" & bb
.Resize(1, 4).Merge
End With
With .Range("e2")
.Value = "送单日期：" & Format(rq, "yyyy年m月d日")
.Resize(1, 3).Merge
End With
With .Range("a3")
.Value = " 客户名称：" & aa
.Resize(1, 4).Merge
End With
With .Range("e3")
.Value = "制单日期：" & Format(Date, "yyyy年m月d日")
.Resize(1, 3).Merge
End With
With .Range("a2:g3")
With .Font
.Name = "Times New Roman"
.Size = 10
.Bold = True
End With
End With
With .Range("a2:d3")
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With .Range("e2:g3")
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("a4:g4")
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Value = Array("序号", "产品名称及型号", "单位", "数量", "单价", "金额", "备注")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Range("a5").Resize(UBound(brr), UBound(brr, 2))
.Value = brr
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
With .Cells(4 + UBound(brr) + 1, 1)
.Value = " 合计人民币金额（大写）：" & dx(Application.Sum(Application.Index(brr, 0, 6)))
.Resize(1, 5).Merge
With .Font
.Bold = True
End With
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With .Cells(4 + UBound(brr) + 1, 6)
.Value = Application.Sum(Application.Index(brr, 0, 6))
.Resize(1, 2).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.NumberFormatLocal = "0.00"
End With
With .Cells(4 + UBound(brr) + 1, 1).Resize(1, 7)
.Borders.LineStyle = xlContinuous
.BorderAround LineStyle:=xlContinuous, Weight:=xlMedium
.Font.Bold = True
End With
With .Range("a4").Resize(1 + UBound(brr) + 1, UBound(brr, 2))
With .Font
.Name = "Times New Roman"
.Size = 10
End With
End With
With .Cells(4 + UBound(brr) + 1 + 2, 1)
.Value = " 注：请收到本单后三日内核对，如有差异请告之，逾期以本单为准。"
.Resize(1, 7).Merge
With .Font
.Name = "Times New Roman"
.Size = 10
End With
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
With .Cells(4 + UBound(brr) + 1 + 3, 1)
.Value = Space(150) & "客户确认（签名）："
.Resize(1, 7).Merge
With .Font
.Name = "Times New Roman"
.Size = 10
End With
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
.Rows(2).Resize(3 + UBound(brr) + 4).RowHeight = 15.75
For j = 0 To UBound(lk)
.Columns(j + 1).ColumnWidth = lk(j)
Next
End With
Next
.SaveAs Filename:=ThisWorkbook.Path & "\送货单" & aa & "（" & Format(rq, "yyyy年m月d日") & "）"
.Close False
End With
Next
Application.ScreenUpdating = True
MsgBox "数据拆分完毕！"
End Sub

复制代码

		自动登录	找回密码
密码			免费注册

[求助] 按送货日期、客户名称、送货单号拆分送货单

评分

评分

评分

评分

评分

评分