从总表提取指定数据到固定的模板

SZ@HK123 · 发表于 2024-4-26 19:24

从总表按派车单号为维度，提取（装货时间/提运单号/货物总件数/货物总毛重/载货清单号/大陆车牌/集装箱编号/商品项简要描述/货物价值/币种/发货人名称）到模板表后另存为新的表，按车次号命名

因为总表是每天都有1个新的表，代码希望是适用于同样格式的表都能运行，其次表里面的车次会不断新增，希望导出的时候能自由选择导出1车或多车，求教各位大神~

baofa2 · 发表于 2024-4-27 10:04

Sub test0() '算是回复另帖追问……
Dim strPath As String, strFile As String, max_ As Long
max_ = Val(InputBox("请输入车次", "输入提示：", 5))
If max_ = 0 Then Exit Sub
strPath = ThisWorkbook.Path & "\"
strFile = strPath & "空白模板.xlsx"
If Dir(strFile) = "" Then MsgBox "!", 64: Exit Sub
strPath = strPath & "Results" & "\"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
DoApp False
Dim results, data, dict As Object
Dim wkb As Workbook, wks As Worksheet
Dim i As Long, j As Long, k As Long, x As Long, y As Long
Dim cnt As Long, pos As Long
Set dict = CreateObject("Scripting.Dictionary")
With Sheet1
data = .Range("A1", .Range("A1").CurrentRegion.Offset(1)).Value
End With
For j = 1 To UBound(data, 2)
If Not dict.Exists(data(1, j)) Then dict.Add data(1, j), j
Next
x = dict("车次")
Set wkb = Workbooks.Open(strFile, 0)
Set wks = wkb.Worksheets(1)
results = wks.UsedRange.Resize(1000, 10).Value
ActiveWindow.WindowState = xlMinimized
For y = 2 To UBound(data) - 1
If Val(data(y, x)) Then
cnt = 6
pos = y
For i = 2 To 3
For j = 1 To 3 Step 2
results(i, j + 1) = Trim(data(y, dict(Replace(results(i, j), ":", ""))))
Next
Next
End If
cnt = cnt + 1
For j = 1 To UBound(results, 2)
If dict.Exists(results(6, j)) Then
results(cnt, j) = data(y, dict(results(6, j)))
End If
Next
If Val(data(y + 1, x)) Or (y + 1) = UBound(data) Then
wks.Copy
With ActiveWorkbook
With .Worksheets(1)
.Range("A1").Resize(cnt, UBound(results, 2)) = results
.UsedRange.Offset(cnt).Clear
End With
.SaveAs strPath & Format(data(pos, x), "第0车"), 51
.Close
End With
k = k + 1
If k = max_ Then Exit For
End If
Next
Set dict = Nothing
Set wks = Nothing
wkb.Close False
Set wkb = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

SZ@HK123 · 发表于 2024-4-27 14:27

baofa2 发表于 2024-4-27 10:04

谢谢指点

SZ@HK123 · 发表于 2024-4-27 14:47

baofa2 发表于 2024-4-27 10:04

大神，还是要把数据复制到这个总表才能运行，在其他同格式的表里面运行不了vba，选择车次的时候可以比如输入2就导出第2车，输入2-5，就把（2.3.4.5）导出，输入2,5（就把第2.第5）导出，这样可以实现吗

baofa2 · 发表于 2024-4-27 16:17

SZ@HK123 发表于 2024-4-27 14:47
大神，还是要把数据复制到这个总表才能运行，在其他同格式的表里面运行不了vba，选择车次的时候可以比如 ...

Sub test0() ' ……
Dim strPath As String, strFile As String, str_ As String
Dim i As Long, j As Long, k As Long, x As Long, y As Long
Dim ar, br, cr() As Long, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
str_ = InputBox("请输入车次", "输入提示：", "2-5,3,6-7,10,12")
If Len(str_) Then
ar = Split(str_, ",")
For i = 0 To UBound(ar)
br = Split(ar(i), "-")
For j = 0 To UBound(br)
If Not dict.Exists(Val(br(j))) Then dict.Add Val(br(j)), ""
Next
Next
Else
MsgBox "未指定车次!", 64: Exit Sub
End If
strPath = ThisWorkbook.Path & "\"
strFile = strPath & "空白模板.xlsx"
If Dir(strFile) = "" Then MsgBox "!", 64: Exit Sub
DoApp False
strPath = strPath & "Results" & "\"
If Dir(strPath, vbDirectory) = "" Then MkDir strPath
Dim results, data, Flag As Boolean
Dim wkb As Workbook, wks As Worksheet, name_ As Name
Dim cnt As Long, pos As Long
With ActiveSheet
data = .Range("A1", .Range("A1").CurrentRegion.Offset(1)).Value
End With
For j = 1 To UBound(data, 2)
If Not dict.Exists(data(1, j)) Then dict.Add data(1, j), j
Next
x = dict("车次")
data(UBound(data), x) = 10 ^ 7
Set wkb = Workbooks.Open(strFile, 0)
Set wks = wkb.Worksheets(1)
results = wks.UsedRange.Resize(1000, 10).Value
ActiveWindow.WindowState = xlMinimized
For j = 1 To UBound(results, 2)
If dict.Exists(results(6, j)) Then
k = k + 1
ReDim Preserve cr(1, 1 To k)
cr(0, k) = j
cr(1, k) = dict(results(6, j))
End If
Next
For y = 2 To UBound(data) - 1
If Val(data(y, x)) Then
Flag = dict.Exists(Val(data(y, x)))
If Flag Then
cnt = 6
pos = y
For i = 2 To 3
For j = 1 To 3 Step 2
results(i, j + 1) = Trim(data(y, dict(Replace(results(i, j), ":", ""))))
Next
Next
End If
End If
If Flag Then
cnt = cnt + 1
For j = LBound(cr, 2) To UBound(cr, 2)
results(cnt, cr(0, j)) = data(y, cr(1, j))
Next
If Val(data(y + 1, x)) Then
wks.Copy
With ActiveWorkbook
With .Worksheets(1)
.Range("A1").Resize(cnt, UBound(results, 2)) = results
.UsedRange.Offset(cnt).Clear
End With
For Each name_ In .Names
name_.Delete
Next
.SaveAs strPath & Format(data(pos, x), "第0车"), 51
.Close
End With
Flag = Not Flag
End If
End If
Next
Set dict = Nothing
Set wks = Nothing
wkb.Close False
Set wkb = Nothing
DoApp
Beep
End Sub
Function DoApp(Optional b As Boolean = True)
With Application
.ScreenUpdating = b
.DisplayAlerts = b
.Calculation = -b * 30 - 4135
End With
End Function

复制代码

SZ@HK123 · 发表于 2024-4-28 15:24

baofa2 发表于 2024-4-27 16:17

大神，太厉害了，可以自由选择自己需要的车次了，但这个报错是什么异常，把代码新建在一个空白的excle表，然后打开同格式的总表操作时报错

baofa2 · 发表于 2024-4-28 15:43

本帖最后由 baofa2 于 2024-4-28 16:31 编辑

SZ@HK123 发表于 2024-4-28 15:24
大神，太厉害了，可以自由选择自己需要的车次了，但这个报错是什么异常，把代码新建在一个空白 ...

最好是给出错的附件
可能是标题字段不统一，其中一个多了冒号（已作处理），还有可能是多了其它的字符

'补充一下，可以改这样，不会出错；但模板中字段与总表不一致，导出就不完整……
If dict.Exists(results(i, j)) Then results(i, j + 1) = Trim(data(y, dict(results(i, j))))

SZ@HK123 · 发表于 2024-4-28 18:21

baofa2 发表于 2024-4-28 15:43
最好是给出错的附件
可能是标题字段不统一，其中一个多了冒号（已作处理），还有可能是多了其它的字符
...

好的，了解，我试试，感谢解答

朱付安 · 发表于 2024-4-28 18:29

付款后v科技东方红

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

[求助] 从总表提取指定数据到固定的模板

评分

评分

评分