从另一个工作簿提取符合要求数据

桑土公的肚子 · 发表于 2024-4-17 10:47

求助各位大神，工作需求，需要从发票导出信息中提取发票号到销售订单中，
1、两表客户名称不一致，销售订单表中有对应关系
2、两表中商品名称不一致，销售订单中有对应关系
要求订单表中的开票公司和发票表中开票公司一致，客户名称一致，商品名称一致，相同商品名的数量一致的情况下，提取发票号，
提取失败的最好标记，说明原因，因为实际工作中两表可能几百行数据。
以下是我自己写的，写了一点不知道咋写了，没有实现请大神帮助

Sub 提取发票号()
Dim src_file As Workbook
Dim dst_file As Workbook
Dim src_sheet1 As Worksheet
Dim dst_sheet1 As Worksheet
Dim src_sheet2 As Worksheet
Dim dst_sheet2 As Worksheet
Dim maxLine1
Dim maxLine2
Dim dst_maxLin1
Dim dst_maxLin2
Dim dst_maxLineS1
Dim dst_maxLineS2
Dim src_path As String
Dim dst_path As String
Dim current_dir As String

' 选择要合并数据的源工作簿和目标工作簿
current_dir = ThisWorkbook.Path
src_path = current_dir & "\销售出库单列表.xlsm"
dst_path = current_dir & "\全量发票查询导出结果.xlsx"
Set source_file = Workbooks.Open(src_path)
Set dst_file = Workbooks.Open(dst_path)

' 选择要合并数据的源工作表和目标工作表
Set source_sheet1 = source_file.Worksheets("销售出库单列表")
Set dst_sheet1 = dst_file.Worksheets("信息汇总表")

   maxLine1 = source_sheet1.Cells(Rows.Count, 3).End(xlUp).Row

   dst_maxLin1 = dst_sheet1.Cells(Rows.Count, 4).End(xlUp).Row


   Set dict = CreateObject("Scripting.Dictionary")
   Set DataRange = source_sheet1.Range("C3:C" & maxLine1)
   For Each cell In DataRange
      If dict.Exists(cell.Value) Then
      dict(cell.Value) = dict(cell.Value) + 1
      Else
      dict.Add cell.Value, 1
      End If
   Next cell

   ar = dst_sheet1.Range("A2:AA" & dst_maxLin1)
   Dim i
   Dim j
   Dim temp
   Dim n
   Dim k
   For i = 3 To maxLine1 Step 1
      temp = dict(source_sheet1.Cells(i, 3).Value)
      n = n + 1
      For j = 1 To temp Step 1
         If (WorksheetFunction.IsNA(Application.VLookup(source_sheet1.Cells(i, 5), source_file.Worksheets("客户名").Range("A:B"), 2, 0))) Then
                  'MsgBox "未找到对应开票名称"
                  source_sheet1.Range("A" & i & ":AL" & i).Interior.Color = 65535
         Else
               For k = 1 To dst_maxLin1 Step 1

               Next k
         End If
      Next j
      i = i + temp - 1
   Next i

End Sub

桑土公的肚子 · 发表于 2024-4-17 11:14

桑土公的肚子 · 发表于 2024-4-17 11:15

桑土公的肚子 · 发表于 2024-4-17 11:18

本帖最后由桑土公的肚子于 2024-4-17 12:12 编辑

limonet · 发表于 2024-4-17 11:23

你这样刷的我不想写了。

桑土公的肚子 · 发表于 2024-4-17 11:26

limonet 发表于 2024-4-17 11:23
你这样刷的我不想写了。

不刷了，哥，求帮助

ykcbf1100 · 发表于 2024-4-17 16:24

表之间的关系有点复杂，简单处理一下。
附件供参考。。。

ykcbf1100 · 发表于 2024-4-17 16:25

参与一下。。。

Sub ykcbf() '//2024.4.17
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
p = ThisWorkbook.Path
f = p & "\发票导出信息.xlsx"
Set ws = ThisWorkbook
Set sh = ws.Sheets("销售订单")
arr = ws.Sheets("商品名对应关系").UsedRange
For i = 1 To UBound(arr)
s = arr(i, 2)
d1(s) = arr(i, 1)
Next
arr = ws.Sheets("客户对应关系").UsedRange
For i = 1 To UBound(arr)
s = arr(i, 2)
d1(s) = arr(i, 1)
Next
Set wb = Workbooks.Open(f, 0)
With wb.Sheets(1)
arr = .UsedRange
wb.Close False
End With
For i = 2 To UBound(arr)
s = d1(arr(i, 2)) & "|" & d1(arr(i, 3))
If Not d.exists(s) Then
d(s) = Array(arr(i, 1), arr(i, 4))
End If
Next
ReDim brr(1 To 1000, 1 To 8)
On Error Resume Next
With sh
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 8)
For i = 2 To UBound(arr)
s = arr(i, 3) & "|" & arr(i, 5)
m = m + 1
brr(m, 1) = d(s)(0)
For j = 1 To UBound(arr, 2) - 1
brr(m, j + 1) = arr(i, j)
Next
If brr(m, 1) = Empty Then
brr(m, 8) = "未查到对应客户发票号"
End If
Next
End With
With ws.Sheets("提取后效果示例")
.UsedRange.Offset(1) = ""
.Columns(1).NumberFormatLocal = "@"
.[a2].Resize(m, 8) = brr
End With
Set d = Nothing
Set d1 = Nothing
Application.ScreenUpdating = True
MsgBox "OK！"
End Sub

复制代码

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

[求助] 从另一个工作簿提取符合要求数据

评分