Сопоставление данных из двух источников и простые вычисления в Excel - PullRequest
Новая
       34

Сопоставление данных из двух источников и простые вычисления в Excel

0 голосов
/ 09 февраля 2020

У меня есть некоторые расчеты, которые мне нужно сделать для набора данных. Расчеты просты (т. Е. Вход 1 x вход 2 = выход), но они принимают входные данные, записанные в двух разных рабочих книгах Excel разными людьми. Из-за разных источников входного сигнала параметры между ними иногда бывают в разных порядках или с немного разными именами - прикрепленная картинка должна показать, что я имею в виду.

Мой план состоял в том, чтобы взять соответствующий лист входной книги 1 и соответствующий лист входной книги 2 и скопировать их в одну рабочую книгу, где я надеюсь сопоставить параметры с каким-то макросом поиска / поиска и выполнить вычисления автоматически, используя al oop для работы над заголовками и вниз по строкам

концепция комбинированного листа enter image description here

Буду очень признателен за любую помощь.

1 Ответ

0 голосов
/ 09 февраля 2020

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

Я использовал «X1» для имени первого листа, «X2» для второго и «Результат» для одного совпадающего значения первых двух: 

Sub MatchingLike_bis()
  Dim arrNames As Variant, sh1 As Worksheet, sh2 As Worksheet, sRez As Worksheet
  Dim lastR1 As Long, lastR2 As Long, arrRez As Variant, arr1 As Variant, arr2 As Variant
  Dim i1 As Long, i2 As Long, El As Variant, k As Long, col1 As Long, col2 As Long
  Dim strProbl1 As String, strProbl2 As String, colTot As Long, boolF As Boolean, i As Long

  arrNames = Split("apple,banana,orange,grape,lemon", ",")
  colTot = UBound(arrNames) + 2 'The array is zero based and A is excepted

  Set sh1 = ThisWorkbook.Sheets("X1")
  Set sh2 = ThisWorkbook.Sheets("X2")
  Set sRez = ThisWorkbook.Sheets("Result")
   lastR1 = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row
   lastR2 = sh2.Range("A" & sh2.Rows.count).End(xlUp).Row

   arr1 = sh1.Range(sh1.Cells(1, 1), sh1.Cells(lastR1, colTot)).Value
   arr2 = sh2.Range(sh2.Cells(1, 1), sh2.Cells(lastR1, colTot)).Value

   'preliminary check if all fruits name has a corespondent in both necessary sheets:__________
   strProbl1 = "": strProbl2 = ""
   For Each El In arrNames
        For i1 = 2 To colTot 'make checking in first sheet
            If InStr(UCase(arr1(1, i1)), UCase(El)) > 0 Then
                boolF = True: Exit For
            End If
        Next i1
        If Not boolF Then strProbl1 = strProbl1 & El & vbCrLf
        boolF = False
        For i2 = 2 To colTot 'make checking in the second sheet
            If InStr(UCase(arr2(1, i2)), UCase(El)) > 0 Then
                boolF = True: Exit For
            End If
        Next i2
        If Not boolF Then strProbl2 = strProbl2 & El & vbCrLf
        boolF = False
   Next
   If strProbl1 <> "" Then MsgBox "In " & sh1.Name & " sheet, the next fruit names are" & _
                " incorrect, or missing:" & vbCrLf & _
                vbCrLf & strProbl1 & vbCrLf & "Please correct the spelling and run the application again!", _
                vbInformation, "Wrong spelling in " & sh1.Name & " worksheet": sh1.Activate: Exit Sub
   If strProbl2 <> "" Then MsgBox "In " & sh2.Name & " sheet, the next fruit names are" & _
                " incorrect, or missing:" & vbCrLf & _
                vbCrLf & strProbl2 & vbCrLf & "Please correct the spelling and run the application again!", _
                vbInformation, "Wrong spelling in " & sh2.Name & " worksheet": sh2.Activate: Exit Sub
   '_________________________________________________________________________________________________

   ReDim arrRez(1 To UBound(arr1, 1), 1 To colTot) 'result array will have exactly the
                                                   'number of rows and columns as arr1
   For i1 = 1 To UBound(arr1, 1)
     If i1 = 1 Then
        arrRez(i1, 1) = Empty
        For i = 2 To colTot
           arrRez(i1, i) = arr1(i1, i)
        Next i
     Else
        For i2 = 1 To UBound(arr2, 1)
            If arr1(i1, 1) = arr2(i2, 1) Then
                arrRez(i1, 1) = arr1(i1, 1)
                'find the right reference in the accepted keys array:
                For Each El In arrNames
                    For k = 2 To colTot
                        If InStr(UCase(arr1(1, k)), UCase(El)) > 0 Then col1 = k
                        If InStr(UCase(arr2(1, k)), UCase(El)) > 0 Then col2 = k
                    Next k
                    If col1 > 0 And col2 > 0 Then
                        arrRez(i1, col1) = arr1(i1, col1) + arr2(i2, col2)
                        col1 = 0: col2 = 0
                    End If
                Next
            End If
        Next i2
     End If
   Next i1
   With sRez.Range(sRez.Range("A1"), sRez.Cells(lastR1, colTot))
    .Value = arrRez
    .EntireColumn.AutoFit
  End With
End Sub

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

...