excel 匹配并检索另一个打开的工作簿中的值

xvw2m8pv  于 12个月前  发布在  其他
关注(0)|答案(1)|浏览(98)

我正在努力创建一个处理从另一个打开的工作簿中检索数据的数据库代码。我有一个主要的工作簿,其上的数据是手动从辅助工作簿中馈送。我希望用一个将位于Personal. XLSB中的宏来自动化这一点。我对数据库很陌生,我正在学习如何解决所有这些问题。

E列(test 5)为匹配条件,如果主工作簿中的E列与辅助工作簿中的E列匹配,则复制单元格D;F;G;H;I; J从辅助工作簿到主工作簿。如果在E列中没有匹配项,则对该行没有任何操作,它需要转到下一行,直到找到匹配项。我已经设法编写了一段代码,但它崩溃了,因为有超过1 k行要匹配。然后我尝试了其他方法(见下文)

主要工作簿
x1c 0d1x的数据
辅助工作簿



这是我正在做的代码,但我放弃了,因为我不明白它。这只是一个烂摊子

Option Explicit

Sub WithButton()
Dim KeyCells As Range
Dim sh_Data As Worksheet '
Dim CellChanged As Integer
Dim LastRow, LastData As Long
Dim Found As Boolean
Dim wb2 As Workbook '

On Error GoTo Handle

With Sh_Record
    If .Range("Z1").Value = "" Then
        .Range("Z1").Value = 0
        CellChanged = .Cells(Rows.Count, "E").End(xlUp).Row
    End If
    
    If .Cells(Rows.Count, "E").End(xlUp).Row > .Range("Z1").Value Then
        Set wb2 = Workbooks.Open("C:\Users\User\Desktop\Second.xlsx")
        Set sh_Data = wb2.Worksheets("data")
        
        CellChanged = .Range("Z1").Value + 1
        LastRow = sh_Data.Cells(Rows.Count, "E").End(xlUp).Row
        LastData = .Cells(Rows.Count, "E").End(xlUp).Row
    
        For i = 1 To LastRow
            If .Range("E" & CellChanged).Value = sh_Data.Range("E" & i) Then
                .Range("D" & CellChanged).Value = sh_Data.Range("D" & i).Value
                .Range("F" & CellChanged).Resize(, 5).Value = sh_Data.Range("F" & i).Resize(, 5).Value
                Found = True
            End If
            If Found = True Or i = LastRow Then
                If CellChanged = LastData Then
                    Exit For
                End If
            If Found = True Then
                Found = False
                CellChanged = CellChanged + 1
            Else
                CellChanged = CellChanged + 1
                End If
                i = 0
            End If
        Next i
        wb2.Close False
        .Range("Z1").Value = CellChanged
    End If
End With
Exit Sub
Handle:
    MsgBox ("Error")
End Sub

字符串

9rygscc1

9rygscc11#

Dictionary对象是获取唯一列表和比较数据的更有效方法。

Option Explicit
Sub Demo()
    Dim objDic As Object
    Dim i As Long, j As Integer, sKey As String
    Dim arrData, rngData As Range
    Dim arrRec, rngRec As Range
    Dim wb2 As Workbook, Sh_Data As Worksheet
    Dim lastRow As Long
    Set objDic = CreateObject("scripting.dictionary")
    ' Open second workbook
    Set wb2 = Workbooks.Open("C:\Users\User\Desktop\Second.xlsx")
    Set Sh_Data = wb2.Worksheets("data")
    ' Read data from sheet
    With Sh_Data
        lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
        Set rngData = .Range("A1", .Cells(lastRow, 12))
    End With
    arrData = rngData.Value
    wb2.Close False
    ' Load Dict with data
    For i = LBound(arrData) + 1 To UBound(arrData)
        objDic(arrData(i, 5)) = i
    Next i    
    Dim Sh_Record As Worksheet, Main_wk As Workbook
    ' Assumes main workbook is opened, get the workbook
    Set Main_wk = Workbooks("SO-77428517.xlsm") ' Modify as needed
    ' Get the sheet
    Set Sh_Record = Main_wk.Sheets("Sheet1") ' Modify as needed
    ' Read data from sheet
    With Sh_Record
        lastRow = .Cells(.Rows.Count, "E").End(xlUp).Row
        Set rngRec = .Range("D1", .Cells(lastRow, 10)) '**change2**
    End With
    arrRec = rngRec.Value
    ' Comparing Col E
    For i = LBound(arrRec) + 1 To UBound(arrRec)
        sKey = arrRec(i, 2) ' **change2**
        If objDic.exists(sKey) Then
            ' Populate Col D to J if matching
            For j = 4 To 10
                arrRec(i, j-3) = arrData(objDic(sKey), j) ' **change2**
            Next
        End If
    Next i
    ' Update main workbook
    rngRec.Value = arrRec
    Set objDic = Nothing
End Sub

字符串

  • Microsoft文档:*

Dictionary object

更新

问题:我希望创建一个规则,如果主工作簿中已经有值,则不从辅助WB复制值。

For j = 4 To 10
                If Len(arrRec(i, j))=0 Then arrRec(i, j) = arrData(objDic(sKey), j)
            Next

相关问题