sao chép các ô vào bảng dựa trên tiêu chí khớp

Tôi đã làm việc trong dự án này được một thời gian và cảm thấy như mình đang đến rất gần nhưng cuối cùng lại gặp vấn đề. Tôi đã lấy các đoạn mã này từ các nguồn khác nhau. Tôi rất vui khi nói rằng tôi không nhận được bất kỳ lỗi nào. Thật không may, tôi cũng không nhận được kết quả.

Tôi có hai tờ, một tờ có dữ liệu tĩnh (chính) và bảng kia được cập nhật hàng tuần sao chép / dán (nguồn) Những gì tôi đang cố gắng làm là khớp dữ liệu được nối từ chính sang nguồn và sao chép các ô cụ thể trên một kết quả khớp. Khi tôi chạy macro, tôi nhận được kết quả trên một dòng trong số 50. Vòng lặp bên trong tiếp tục đến tận cùng của trang tính nhưng vòng lặp bên ngoài dường như không thay đổi hàng trên trang đích (chính) Tôi không thực sự chắc chắn làm thế nào một hàng đang được dân cư. Tôi biết tôi đang thiếu một cái gì đó ở đây nhưng những gì?

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

Tôi sẽ rất vui khi tải lên bảng tính nếu có cách để làm điều đó

Vì bạn không chỉ định tiêu chí cũng như không đính kèm dữ liệu mẫu. Vì vậy, tôi muốn đề xuất cho bạn phương pháp tương tự để sao chép dữ liệu trùng khớp từ trang này sang trang khác.

NB: Mã này khớp với Ô A1 từ cả hai trang tính, để Sao chép dữ liệu.

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

Lưu ý, với lệnh Offset, bạn có thể thay đổi phạm vi dữ liệu theo nhu cầu của mình. Ngoài ra, mã này đã được tôi kiểm tra trước khi tôi tải lên ở đây.

Tôi hy vọng điều này sẽ giúp bạn.

Tôi thấy tất cả các phạm vi bù đắp khá khó hiểu, điều gì xảy ra nếu bạn chỉ đơn giản là bù đắp rngsvà 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

Có một cách khác để lặp qua các ô của bạn:

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

Cách khác:

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

Cũng nên làm việc