Блог

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

 mHeaders = Array("Column 1", "Column 2", "Column 3")
soHeaders = Array("Column 1", "Column 2", "Column 3")

wsDestHeaders = getIndexes(wsDest.Rows(2), mHeaders) 'mheaders includes the headers of sheet 1
wsSrcHeaders = getIndexes(wsSrc.Rows(2), soHeaders) 'sheaders includes the headers of sheet 2

'Setting first and last row for the columns in both sheets
    wsDestSORow = 3              'The row we want to start processing first
    wsDestEndRow = wsDest.UsedRange.Rows(wsDest.UsedRange.Rows.count).Row
    wsSrcSORow = 3              'The row we want to start search first
    wsSrcEndRow = wsSrc.UsedRange.Rows(wsSrc.UsedRange.Rows.count).Row

For i = wsDestSORow To wsDestEndRow        'first and last row
            For j = wsSrcSORow To wsSrcEndRow 'first and last row
                    'copying data where headers match
                    For k = LBound(wsSrcHeaders) To UBound(wsSrcHeaders)
                        wsDest.Cells(i, wsDestHeaders(k)) = wsSrc.Cells(j, wsSrcHeaders(k))
                    
                    Next k
                Exit For
            Next j
         Exit For
     Next i

Function getIndexes(toSearch As Range, aValues As Variant) As Variant
Dim i As Integer
Dim var As Variant
Dim aRes As Variant
    'determining the size of the array of headers
    ReDim aRes(LBound(aValues) To UBound(aValues))
    For i = LBound(aValues) To UBound(aValues)
    'matching the array values to the headers in the header row
        var = Application.Match(aValues(i), toSearch, 0)
        'returns the column index  number
        If Not IsError(var) Then
            aRes(i) = var
        Else
            MsgBox "Column '" amp; aValues(i) amp; "' was not found in " amp; toSearch.Address(False, False, xlA1, True)
            End
        End If
    Next i
    getIndexes = aRes
End Function

  

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

Вы не ответили на мои уточняющие вопросы…

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

 Sub testCopyColunsByHeaders()
  Dim wsDest As Worksheet, wsSrc As Worksheet, wsSrcEndRow As Long
  Dim arr, wsSrcHeaders, El, matchS As Long, matchD As Long, rngHS As Range
  Dim lastColS As Long, lastColD As Long, headersRow As Long, rngHD As Range
  
  headersRow = 1          'use here the row where the headers exist
  wsSrcHeaders = Split("Column 1,Column 3,Column 9", ",")
  Set wsSrc = ActiveSheet 'use here your source sheet
  Set wsDest = wsSrc.Next 'use here your destination sheet

  wsSrcEndRow = wsSrc.UsedRange.rows.count  'last row of the source sheet
  lastColS = wsSrc.UsedRange.Columns.count  'last col of the source sheet
  lastColD = wsDest.UsedRange.Columns.count 'last col of the destination sheet
  Set rngHS = wsSrc.Range("A" amp; headersRow, wsSrc.cells(headersRow, lastColS))   'headers range
  Set rngHD = wsDest.Range("A" amp; headersRow, wsDest.cells(headersRow, lastColD)) 'headers range
  
  For Each El In wsSrcHeaders 'iteration between headers array elements
    matchS = IsMatch(rngHS, CStr(El)): matchD = IsMatch(rngHD, CStr(El)) 'extract the matching pos
    If matchS > 0 And matchD > 0 Then
        'build the array to be transferred:
        arr = wsSrc.Range(wsSrc.cells(3, matchS), wsSrc.cells(wsSrcEndRow, matchS)).Value
        wsDest.cells(3, matchD).Resize(UBound(arr), 1).Value = arr 'drop the array at once
    Else
        'warning in case of not matching header:
        MsgBox El amp; " header does not exist in both sheets..."
    End If
  Next
End Sub
Private Function IsMatch(rng As Range, strS As String) As Long
    On Error Resume Next
    IsMatch = WorksheetFunction.Match(strS, rng, 0)
    If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0
        IsMatch = 0
    End If
    On Error GoTo 0
End Function
  

Пожалуйста, протестируйте его и отправьте несколько отзывов или уточняющих вопросов, если что-то недостаточно ясно.

Объявление всех задействованных переменных поможет вам сохранить аккуратный фрагмент кода и легко отладить его в случае возникновения проблем…

Если вы хотите скопировать первые три столбца, не нужно никаких итераций. Все они могут быть скопированы сразу.