☰

Как объединить данные из двух файлов Excel с разной структурой?

tag-icon • tag-icon microsoft-excel vba
Как объединить данные из двух файлов Excel с разной структурой?

У меня есть два очень больших файла Excel с финансовыми данными. Мне нужно объединить данные из одного файла с данными из другого. Всем строкам в первом файле назначен код категории. Некоторые строки во втором файле могут иметь тот же код.
Мне нужно объединить все строки из первого файла со всеми соответствующими строками с тем же кодом из второго файла. Файлы имеют разное количество столбцов.

Как мне с этим справиться?

решение1

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

Вот один из способов сделать это в VBA. Этот код будет копироваться только в том случае, если ячейка, содержащая значение NACE, та же самая, но вы можете изменить ее для своих нужд. Сейчас он просто копирует всю строку в первую рабочую книгу.

Private Sub CopyRows()

Dim FirstSheet As Range
Dim SecondSheet As Range
Dim s1col As Integer, s2col As Integer
Dim nextrow As Integer, secondendrow As Integer
Dim copyrow As Range, col As Range
Dim firstsheetrow As Range, secondsheetrow As Range
Dim NACE() As String, Limit As Integer, Index As Integer
Dim testrange As Range

Set FirstSheet = ActiveSheet.UsedRange
Set SecondSheet = Workbooks("Book2").Sheets("Sheet1").UsedRange

For Each col In FirstSheet.Columns
    If Not col.Cells(1).Find("NACE") Is Nothing Then
        s1col = col.Column
        Exit For
    End If
Next col

For Each col In SecondSheet.Columns
    If Not col.Cells(1).Find("NACE") Is Nothing Then
        s2col = col.Column
        Exit For
    End If
Next col


''//Fill NACE array with distinct entries from first sheet
nextrow = FirstSheet.Rows.Count + 1

ReDim Preserve NACE(1 To 1)
NACE(1) = FirstSheet.Rows(2).Cells(1, s1col).Value

For Each firstsheetrow In FirstSheet.Range("3:" & nextrow - 1).Rows
    Limit = UBound(NACE)
    If instrArray(NACE, firstsheetrow.Cells(1, s1col).Value) = 0 Then
        ReDim Preserve NACE(1 To Limit + 1)
        NACE(Limit + 1) = firstsheetrow.Cells(1, s1col).Value
    End If
Next firstsheetrow

''//Copy lines from second sheet that match a NACE value on the first sheet
secondendrow = SecondSheet.Rows.Count

For Each secondsheetrow In SecondSheet.Range("2:" & secondendrow).Rows
    Index = instrArray(NACE, secondsheetrow.Cells(1, s2col).Value)
    If Index > 0 Then
        secondsheetrow.Copy
        ActiveSheet.Rows(nextrow).PasteSpecial (xlPasteValues)
    End If
Next secondsheetrow

End Sub

Этот код необходимо поместить в модуль для поддержки основной процедуры:

Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (pDest As Any, _
   pSrc As Any, _
   ByVal ByteLen As Long)

Public Function GetArrayDimensions(ByVal arrPtr As Long) As Integer

   Dim address As Long
  'get the address of the SafeArray structure in memory

   CopyMemory address, ByVal arrPtr, ByVal 4

  'if there is a dimension, then
  'address will point to the memory
  'address of the array, otherwise
  'the array isn't dimensioned
   If address <> 0 Then

     'fill the local variable with the first 2
     'bytes of the safearray structure. These
     'first 2 bytes contain an integer describing
     'the number of dimensions
      CopyMemory GetArrayDimensions, ByVal address, 2

   End If

End Function

Public Function VarPtrArray(arr As Variant) As Long

  'Function to get pointer to the array
   CopyMemory VarPtrArray, ByVal VarPtr(arr) + 8, ByVal 4

End Function

Function instrArray(strArray, strWanted, _
    Optional CaseCrit As Boolean = False, _
    Optional FirstOnly As Boolean = True, _
    Optional Location As String = "exact") As Long
     '
     '****************************************************************************************
     '       Title       instrArray
     '       Target Application:  any
     '       Function:   searches string array for some "wanted" text
     '       Limitations:
     '       Passed Values:
     '           strArray    [in, string array]  array to be searched
     '           strWanted   [in, string]  text for which strArray is searched
     '           CaseCrit    [in, Boolean, Optional]
     '               if true, case (upper/lower) of each character is critical and must match
     '               if false, case is not critical {default}
     '           FirstOnly   [in, Boolean, Optional]
     '               if true, proc exits after first instance is found {default}
     '               if false, proc search to end of array and last instance # is returned
     '           Location    [in, string, Optional] text matching constraint:
     '               = "any"     as long as strWanted is found anywhere in strArray(k),i.e.,
     '                               instr(strArray(k),strWanted) > 0, then instrArray = K
     '               = "left"    match is successful only if
     '                               Left(strArray(K),Len(strWanted) = StrWanted
     '               = "right"    match is successful only if
     '                               Right(strArray(K),Len(strWanted) = StrWanted
     '               = "exact"    match is successful only if
     '                               strArray(K) = StrWanted       {default}
     '
     '****************************************************************************************
     '
     '
    Dim I       As Long
    Dim Locn    As String
    Dim strA    As String
    Dim strB    As String

    instrArray = 0
    Locn = LCase(Location)
    Select Case FirstOnly
        Case True
            For I = LBound(strArray) To UBound(strArray)
                Select Case CaseCrit
                Case True
                    strA = strArray(I):     strB = strWanted
                Case False
                    strA = LCase(strArray(I)):  strB = LCase(strWanted)
                End Select
                If instrArray2(Locn, strA, strB) > 0 Then
                    instrArray = I
                    Exit Function
                End If
            Next I
        Case False
            For I = UBound(strArray) To LBound(strArray) Step -1
                Select Case CaseCrit
                Case True
                    strA = strArray(I):     strB = strWanted
                Case False
                    strA = LCase(strArray(I)):  strB = LCase(strWanted)
                End Select
                If instrArray2(Locn, strA, strB) > 0 Then
                    instrArray = I
                    Exit Function
                End If
            Next I
    End Select

End Function

Function instrArray2(Locn, strA, strB)
     '
     '****************************************************************************************
     '       Title       instrArray2
     '       Target Application:  any
     '       Function    called by instrArray to complete test of strB in strA
     '       Limitations:    NONE
     '       Passed Values:
     '           Locn    [input, string] text matching constraint (see instrArray)
     '           strA    [input, string] 1st character string
     '           strB    [input, string] 2nd character string
     '
     '****************************************************************************************
     '
     '

    Select Case Locn
    Case "any"
        instrArray2 = InStr(strA, strB)
    Case "left"
        If Left(strA, Len(strB)) = strB Then instrArray2 = 1
    Case "right"
        If Right(strA, Len(strB)) = strB Then instrArray2 = 1
    Case "exact"
        If strA = strB Then instrArray2 = 1
    Case Else
    End Select

End Function

Код утилиты найденздесьиздесь.

решение2

Именно для таких задач предназначен Microsoft Access, и он называется "Left Join". Но вы все равно можете сделать это в Excel, используя vlookup или функцию match и index. Лично я предпочитаю match/index.

Предположим, что Sheet1 A:F — первый файл, а второй файл вы кладете на Sheet2 A1:Q500. Допустим, ваши коды находятся в столбце A обоих. Затем на sheet1 в G2 введите это:

=MATCH(A2,Sheet2!A$1:A$500,0)

Затем в H2 введите:

=INDEX(Sheet2!B$1:B$500,$G2)

Затем перетащите это и перетащите все это вниз.

решение3

В зависимости от размера двух файлов вы также можете попробовать использовать запрос из файлов Excel:

  • Определите имя для первой таблицы Excel (вкладка «Формулы» -> «Определить имя»)
  • Определить имя для второй таблицы Excel
  • Перейдите на вкладку «Данные», выберите «Из других источников», а в раскрывающемся списке выберите «Из Microsoft Query».
  • Выберите файл рабочей книги и подтвердите, что вы хотите вручную объединить столбцы.
  • В следующем окне «Запрос из файлов Excel» перетащите первый столбец первой таблицы в первый столбец второй таблицы — между этими столбцами будет создана связь.
  • Перейдите в меню «Файл», нажмите «Вернуть данные в MS Office Excel», появится диалоговое окно «Импорт данных».
  • Выберите лист, в который вы хотите импортировать сопоставленные данные.
  • Нажмите OK -> вы должны увидеть сопоставленные данные со столбцами из обеих таблиц.

Связанный контент