копировать ячейки в лист на основе соответствия критериям

Question

Я работаю над этим проектом некоторое время и чувствую, что подхожу так близко, но сталкиваюсь с проблемами в конце. Я вытащил кусочки этого кода из разных источников. Я счастлив сказать, что я не получаю никаких ошибок. К сожалению, я тоже не получаю результатов.

У меня есть два листа, один из которых содержит статические данные (основной), а другой обновляется еженедельно в режиме копирования / вставки (источник). Я пытаюсь сопоставить объединенные данные из основного в исходный и скопировать определенные ячейки в соответствии. когда я запускаю макрос, я получаю результаты в одной строке из 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

Я буду рад загрузить книгу, если есть способ сделать это

Answer 1

Я нахожу все смещение диапазона довольно запутанным, что произойдет, если вы просто 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

Должен также работать

Answer 2

Поскольку вы не указали критерии и не приложили пример данных. Так что я хотел бы предложить вам аналогичный метод для копирования сопоставленных данных с одного листа на другой.

NB. Этот код соответствует ячейке 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

Обратите внимание, что с помощью команды «Смещение» вы можете изменить диапазон данных по своему усмотрению. Кроме того, этот код был проверен мной, прежде чем я загрузил здесь.

Я надеюсь, что это поможет вам.