如何使用 vba 将来自两个单独数据表的单元格与特定请求合并

Question

我已经开始编写一个 vba 脚本来使用我需要的一些条件合并来自两个单独工作表的数据。代码还没有完成，因为我不知道下一步该怎么做，而且我确信有一个更好、更简单的解决方案。首先是我的代码：

 Sub test()
Dim RD As Range
Set RD = Worksheets("TEST").Range("A1:A3")
With RD
    .TextToColumns Comma:=True, DataType:=xlDelimited
End With

Dim Rng As Range
Dim WorkRng As Range
Dim xOut As Variant
Dim i As Long
Dim xTemp As Variant
Dim xStr As Variant
On Error Resume Next

Set WorkRng = Worksheets("TEST").Range("A1:C3")
For Each Rng In WorkRng
    xOut = ""
    For i = 1 To Len(Rng.Value)
        xTemp = Mid(Rng.Value, i, 1)
        If xTemp Like "[0-9]" Then
            xStr = xTemp
        Else
            xStr = ""
        End If
        xOut = xOut & xStr
    Next i
    Rng.Value = xOut
Next

Dim Range1 As Range, Range2 As Range
Dim rowIndex As Integer

Set Range1 = Worksheets("TEST").Range("A1:C3")
Set Range2 = Worksheets("TEST").Range("A8")
rowIndex = 0
For Each Rng In Range1.Rows
    Rng.Copy
    Range2.Offset(rowIndex, 0).PasteSpecial Paste:=xlPasteAll, Transpose:=True
    rowIndex = rowIndex + Rng.Columns.Count
Next

Dim counter As Integer
counter = 0

For i = 1 To 20
    If Cells(i, 1).Value <> "" Then
        Cells(counter + 1, 2).Value = Cells(i, 1).Value
        counter = counter + 1
    End If
Next i
End Sub

我在两张纸上有两个单独的数据。我想以某种方式将它们合并在一起。这是数据：

Sheet1                                  Sheet2
A          B                            A          B
8.2.2021   21009                        328598     41520 (Ottawa)
           21031                        326548     41940 (Washington), 41540 (London), 48950 (Sydney)
8.2.2021   41940                        325685     21009 (New York), 21031 (Tokyo)
           41540                        325614     41520 (Ottawa)
           48950
8.2.2021   41520                
8.2.2021   41520

在 Sheet1 上，第一个包含日期（A 列）和商店的一些代码（B 列）。在 Sheet2 上，第二个有他们所需的订单号（A 列），商店也有，但格式不同（B 列）。我想以某种方式将它们合并在一起，将 Sheet2 中的订单号放在其他 2 列旁边（因此放入 C 列），当然放入它们相应的行，放入包含订单日期的行（在 A 列中） ) 。（请参阅第三个 table 了解它应该是什么样子。）请注意如何可以有多行具有相同的商店，但订单号不同。

如果是这样，并且如果他们有相同的订单日（A 列 Table 1），那么重要的一件事是他们需要有不同的订单号（B 列Table 2).否则，他们将有不同的订单日（A 列 Table 1）。

最终应该是这样的：

A          B      C
8.2.2021   21009  325685
           21031  
8.2.2021   41940  326548
           41540
           48950
8.2.2021   41520  328598
8.2.2021   41520  325614

我的代码将第二个 table B 列分成不同的单元格，删除字母，因此只保留商店编号，然后将它们放入一个列中。我不知道我是否走在解决这个问题的正确道路上。代码完成后看起来像这样：

Sheet1                    Sheet2
A          B              A          B          
8.2.2021   21009          328598     41520
           21031          326548     41940
8.2.2021   41940          325685     41540
           41540          325614     48950
           48950                     21009
8.2.2021   41520                     21031
8.2.2021   41520                     41520

Answer 1

使用正则表达式提取商店编号，并使用 Dictionary Object 以商店为键，以订单号集合为值。

Option Explicit

Sub test()

    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
   
    Dim Regex As Object
    Set Regex = CreateObject("vbscript.regexp")

    With Regex
       .Global = True
       .MultiLine = False
       .IgnoreCase = True
       .Pattern = "\d+" ' any digits
    End With

    Dim wb As Workbook, ws1 As Worksheet, ws2 As Worksheet
    Set wb = ThisWorkbook
    Set ws1 = wb.Sheets("Sheet1")
    Set ws2 = wb.Sheets("Sheet2")
    
    Dim i As Long, n As Integer, s As String, ar As Variant
    Dim c As Collection
    Dim sStore As String, sOrder As String, sLastOrder As String
    
    ' scan sheet 2 column b to fill dictionary
    For i = 1 To ws2.Cells(Rows.Count, "B").End(xlUp).Row
        sOrder = ws2.Cells(i, "A")
        s = ws2.Cells(i, "B")
        If Regex.test(s) Then
            Set ar = Regex.Execute(s)
            For n = 1 To ar.Count
                sStore = CStr(ar.Item(n - 1))
                If dict.exists(sStore) Then
                    dict(sStore).Add sOrder
                Else
                    Set c = New Collection
                    c.Add sOrder
                    dict.Add sStore, c
                End If
            Next
        Else
            MsgBox "No stores in " & s, vbCritical, ws2.Name & " row " & i
        End If
    Next
    
   ' scan stores in sheet 1 col B and fill in column C with orders
    For i = 1 To ws1.Cells(Rows.Count, "B").End(xlUp).Row
        sStore = ws1.Cells(i, "B")
        If dict.exists(sStore) Then
            ' check there are orders for this store
            If dict(sStore).Count > 0 Then
                sOrder = dict(sStore).Item(1)
                ' don't repeat
                If sOrder <> sLastOrder Then
                    ws1.Cells(i, "C") = sOrder
                End If
                dict(sStore).Remove (1)
                sLastOrder = sOrder
            Else
                MsgBox "No orders left for store " & sStore, vbCritical, ws1.Name & " Row " & i
            End If
        Else
            MsgBox "No orders for store " & sStore, vbCritical, ws1.Name & " Row " & i
        End If
    Next
    MsgBox "Finished"
    
End Sub

如何使用 vba 将来自两个单独数据表的单元格与特定请求合并

How to combine cells from two separate data sheets with specific requests using vba

excel

vba

excel-2013