☰

根据条件匹配将单元格复制到工作表

tag-icon • tag-icon microsoft-excel vba
根据条件匹配将单元格复制到工作表

我已经在这个项目上工作了一段时间，感觉自己已经非常接近目标了，但最后却遇到了问题。我从不同的来源提取了这段代码。我很高兴地说我没有遇到任何错误。不幸的是，我也没有得到结果。

我有两张工作表，一张包含静态数据（主工作表），另一张每周通过复制/粘贴更新（源工作表）。我尝试将连接的数据从主工作表匹配到源工作表，并复制匹配项上的特定单元格。当我运行宏时，我得到 50 条结果中的一条。内循环一直持续到工作表的底部，但外循环似乎没有改变目标工作表（主工作表）上的行。我不太确定一行是如何填充的。我知道我在这里遗漏了什么，但是什么呢？

Dim wsSource As Worksheet
Dim wsMain As Worksheet
Dim rngs As Variant
Dim rngm As Variant
Dim srow As Integer
Dim mrow As Integer
Dim i As Long
Dim lastrow As Long




Set wsSource = Worksheets("Source")
Set wsMain = Worksheets("Main")

Set rngs = wsSource.Range("L2")
Set rngm = wsMain.Range("L2")





    'Clear old data
    wsMain.Range("D2:L1500").ClearContents
    wsSource.Range("L2:L1500").ClearContents


    wsMain.Range("L2:L" & Range("A65000").End(xlUp).Row).FormulaR1C1 = "=CONCATENATE(RC[-11],RC[-10],RC[-9])"
    wsSource.Range("L2:L" & Range("A65000").End(xlUp).Row).FormulaR1C1 = "=CONCATENATE(RC[-11],RC[-10],RC[-9])"

    lastrow = Range("L" & Rows.Count).End(xlUp).Row
    srow = 2
    mrow = 2


    Do Until rngm.Offset(mrow, 0).Value <> "" And rngm.Offset(mrow, 1).Value <> ""


        Do Until rngs.Offset(srow, 0).Value <> "" And rngs.Offset(mrow, 1).Value <> ""

            If (rngs.Offset(srow, 0).Value = rngm.Offset(mrow, 0).Value) Then

            rngm.Offset(mrow, -8).Value = rngs.Offset(srow, -8).Value
            rngm.Offset(mrow, -7).Value = rngs.Offset(srow, -7).Value
            rngm.Offset(mrow, -6).Value = rngs.Offset(srow, -6).Value
            rngm.Offset(mrow, -5).Value = rngs.Offset(srow, -5).Value
            rngm.Offset(mrow, -4).Value = rngs.Offset(srow, -4).Value
            rngm.Offset(mrow, -3).Value = rngs.Offset(srow, -3).Value
            rngm.Offset(mrow, -2).Value = rngs.Offset(srow, -2).Value
          End If
        srow = srow + 1
        Loop
    mrow = mrow + 1
Loop

如果有办法的话，我很乐意上传工作簿

答案1

由于您既未指定条件，也未附上样本数据。因此，我建议您使用类似的方法将匹配的数据从一张表复制到另一张表。

注意： 此代码与两张工作表中的单元格 A1 匹配，以复制数据。

Sub Copy&Paste()

Dim sht As Worksheet 
Dim newsht As Worksheet 

Set sht = ThisWorkbook.Worksheets("Sheet1")
Set newsht = ThisWorkbook.Worksheets("Sheet2")

Set dat = sht.Range("A1")
Set newdat = newsht.Range("A1")

Dim i, j, iRow As Integer   
i = 1
j = 1
iRow = 1

'For Header Row
newdat.Offset(0, 0).Value = dat.Offset(0, 0).Value 
newdat.Offset(0, 1).Value = dat.Offset(0, 2).Value 
newdat.Offset(0, 2).Value = dat.Offset(0, 3).Value 
newdat.Offset(0, 3).Value = dat.Offset(0, 4).Value 
newdat.Offset(0, 4).Value = dat.Offset(0, 5).Value 
newdat.Offset(0, 5).Value = dat.Offset(0, 6).Value 

Do While dat.Offset(i, 0).Value <> "" Or dat.Offset(i, 1).Value <> ""

  j = 1     

  Do While dat.Offset(j, 0).Value <> ""

    If (newdat.Offset(i, 0).Value = dat.Offset(j, 4).Value _
    Or newdat.Offset(i, 1).Value = dat.Offset(j, 5).Value) _
    And dat.Offset(j, 6).Value = "your criteria" Then

    'This copies Data.

      newdat.Offset(iRow, 0).Value = dat.Offset(j, 0).Value 
      newdat.Offset(iRow, 1).Value = dat.Offset(j, 2).Value 
      newdat.Offset(iRow, 2).Value = dat.Offset(j, 3).Value 
      newdat.Offset(iRow, 3).Value = dat.Offset(j, 4).Value 
      newdat.Offset(iRow, 4).Value = dat.Offset(j, 5).Value 
      newdat.Offset(iRow, 5).Value = dat.Offset(j, 6).Value 
      iRow = iRow + 1
    End If
    j = j + 1     
  Loop

  i = i + 1     

Loop

End Sub

注意，使用 Offset 命令，您可以根据需要更改数据范围。此外，我在上传之前已经测试过此代码。

我确实希望这对你有帮助。

答案2

我发现所有范围的偏移都相当令人困惑，如果你只是偏移rngs和，会发生什么rngm？

Set rngs = wsSource.Range("L4") ' L2 offset by (2,0)
Set rngm = wsMain.Range("L4") ' L2 offset by (2,0)

Do Until rngm.Value <> "" And rngm.Offset(0, 1).Value <> ""
    Do Until rngs.Value <> "" And rngs.Offset(0, 1).Value <> ""
        If (rngs.Value = rngm.Value) Then
            wsMain.Range("D" & rngm.row & "J" & rngm.row) = wssource.Range("D" & rngs.row & "J" & rngs.row)
        End If
        Set rngs = rngs.Offset(1,0)
    Loop
    Set rngm = rngm.Offset(1,0)
Loop

还有另一种方法可以循环遍历您的单元格：

For i = 5 to wsSource.Range("L" & Rows.Count).End(xlUp).Row
    Set rngm = wsSource.Range("L" & i)
    For j = 5 to wsSource.Range("L" & Rows.Count).End(xlUp).Row
        Set rngs = wsSource.Range("L" & j)
        If (rngs.Value = rngm.Value) Then
            wsMain.Range("D" & i & "J" & i) = wssource.Range("D" & j & "J" & j)
            Exit For
        End If
    Next j
Next i

或者：

For each rngm in wsSource.Range("L5:L" & Rows.Count).End(xlUp).Row
    For each rgns in wsSource.Range("L5:L" & Rows.Count).End(xlUp).Row
        If (rngs.Value = rngm.Value) Then
            wsMain.Range("D" & rngm.row & "J" & rngm.row) = wssource.Range("D" & rngs.row & "J" & rngs.row)
            Exit For
        End If
    Next rngs
Next rngm

也应该有效

相关内容