如何遍历数据转储并将唯一值粘贴到两个单独的表中 [VBA]

Question

我目前有两个 spreadsheets：一个从 SQL 服务器提取数据并且是一个数据转储，另一个需要将这些值填充到其中。为了简单起见，我编译了一个迷你原型以用于我的问题。需要注意的是，数据转储 sheet 将有不同数量的行，但列将是静态的，这应该有助于轻松映射。我需要我的宏来完成的是

检查 ID 值是否与其正下方的值匹配，如果匹配
检查 Spouse_Indicator 字段是否有“N”或“Y”值
如果指标是“N”值，那么我需要将雇主和职位字段中的相应行填充到学生中 table
如果指标是“Y”值，那么我需要将雇主和头衔字段中的相应行填充到配偶中 table
如果有 ID 与其正下方的 ID 不匹配的序列，数据会自动填充到学生中 table

我在设置宏时遇到的问题是，只有带有“N”指示符的最新 ID 会填充到学生的每个单元格中 table，而我需要在读取最后一个 ID 之前，只填充唯一值。所附图片显示了数据的一小部分样本，第一个 table 显示了我的宏生成的内容，而最后一个 table 显示了我的目标。我还包括我的代码以显示我到目前为止所获得的内容。如果我需要澄清任何事情，请告诉我，非常感谢。

Sub test2()

Dim wb As Workbook
Dim ws As Worksheet
Dim id As Range
Dim cell As Range
Dim student_employer As Range

Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Set id = ws.Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
Set student_employer = ws.Range("G3:G8")

For Each cell In id
    If cell.Value = cell.Offset(1, 0).Value And cell.Offset(0, 1).Value = "N" Then
        cell.Offset(0, 2).Copy student_employer.Cells
    End If
Next

MsgBox ("DONE")

End Sub

我已经编辑了我的代码，它在某种程度上捕捉了我想要完成的事情，但是我需要将值粘贴到下一个空单元格中，而我的当前跳过单元格的数量取决于下一个单元格的时间copy-paste 发生。

Sub test2()

Dim id As Long
Dim x As Long
Dim emp As Range
Set emp = Range("G3:G8")

id = Cells(Rows.Count, "A").End(xlUp).Row

For x = 2 To id
If Cells(x, 1).Value = Cells(x, 1).Offset(1, 0) Then
    Cells(x, 1).Offset(0, 2).Copy Cells(x, 6).Offset(1, 0)
End If

Next x

MsgBox ("DONE")

End Sub

Answer 1

复制唯一行

调整常量部分的值。如果您愿意，请使用注释掉的常量和 sCols 来删除 'magic' 数字 (1, 2, 3, 4).
为简单起见，假设源数据从单元格A1开始（CurrentRegion）。

Option Explicit

Sub test1()
    
    Const sName As String = "Sheet1"
    'Const sCritCol As Long = 2
    'Const sColsList As String = "1,3,4"
    'Const scCount As Long = 4
    Const sCrit1 As String = "N"
    Const sCrit2 As String = "Y"
    
    Const dName As String = "Sheet1"
    Const dFirst As String = "F1"
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
    
    If srg.Columns.Count <> 4 Then Exit Sub
    
    Dim srCount As Long: srCount = srg.Rows.Count
    If srCount = 1 Then Exit Sub
    
    Dim sData As Variant: sData = srg.Value
    
    'Dim sCols() As String: sCols = Split(sColsList, ",")
    
    Dim dict1 As Object: Set dict1 = CreateObject("Scripting.Dictionary")
    dict1.CompareMode = vbTextCompare
    Dim dict2 As Object: Set dict2 = CreateObject("Scripting.Dictionary")
    dict2.CompareMode = vbTextCompare
    
    Dim cDat As Variant: ReDim cDat(1 To 3)
    
    Dim Key As Variant
    Dim sCrit As Variant
    Dim r As Long
    For r = 2 To srCount
        sCrit = sData(r, 2)
        Select Case UCase(CStr(sCrit))
        Case sCrit1
            Key = sData(r, 1)
            If Not dict1.Exists(Key) Then
                cDat(1) = sData(r, 1)
                cDat(2) = sData(r, 3)
                cDat(3) = sData(r, 4)
                dict1(Key) = cDat
            End If
        Case sCrit2
            Key = sData(r, 1)
            If Not dict2.Exists(Key) Then
                cDat(1) = sData(r, 1)
                cDat(2) = sData(r, 3)
                cDat(3) = sData(r, 4)
                dict2(Key) = cDat
            End If
        End Select
    Next r
    
    Dim drCount As Long: drCount = dict1.Count + dict2.Count + 4
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To 3)
    
    r = 1
    dData(r, 1) = "student"
    r = r + 1
    dData(r, 1) = sData(1, 1)
    dData(r, 2) = sData(1, 3)
    dData(r, 3) = sData(1, 4)
    
    Dim n As Long
    If dict1.Count > 0 Then
        For Each Key In dict1.Keys
            r = r + 1
            For n = 1 To 3
                dData(r, n) = dict1(Key)(n)
            Next n
        Next Key
    End If
    
    r = r + 1
    dData(r, 1) = "spouse"
    r = r + 1
    dData(r, 1) = sData(1, 1)
    dData(r, 2) = sData(1, 3)
    dData(r, 3) = sData(1, 4)
    
    If dict2.Count > 0 Then
        For Each Key In dict2.Keys
            r = r + 1
            For n = 1 To 3
                dData(r, n) = dict2(Key)(n)
            Next n
        Next Key
    End If
            
    Application.ScreenUpdating = False
            
    ' Write.
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim drg As Range: Set drg = dws.Range(dFirst).Resize(r, 3)
    drg.Clear ' because of merged cells
    drg.Value = dData
    
    ' Clear below.
    Dim crg As Range
    Set crg = drg.Resize(dws.Rows.Count - drg.Row - r + 1).Offset(r)
    crg.Clear

    ' Format 'student'
    With drg.Rows(1)
        .Cells(1).Font.Bold = True
        .MergeCells = True
        .HorizontalAlignment = xlCenter
        .BorderAround xlContinuous, xlThick
    End With
    
    ' Format 'spouse'.
    With drg.Rows(dict1.Count + 3)
        .Cells(1).Font.Bold = True
        .MergeCells = True
        .HorizontalAlignment = xlCenter
        .BorderAround xlContinuous, xlThick
    End With
    
    ' Format all.
    drg.EntireColumn.AutoFit
    
    Application.ScreenUpdating = True
    
    MsgBox ("DONE")

End Sub

如何遍历数据转储并将唯一值粘贴到两个单独的表中 [VBA]

How to iterate through a datadump and paste unique values into two separate tables [VBA]

excel

foreach

vba

loops

复制唯一行