Сравнить два столбца? - PullRequest
1 голос
/ 29 мая 2020

Позвольте мне предварить этот вопрос, сказав, что я абсолютно не понимаю, что я делаю, когда дело доходит до VBA и написания кода.

Я пытаюсь создать макрос, чтобы сделать следующее: 1) Нажмите кнопка, которая открывает диалоговое окно открытия нескольких файлов 2) Сохраните исходный файл как новое имя файла 3) Создайте вкладку результатов в новом имени файла.

Вышеупомянутые 3 у меня работают, хотя это может быть не так довольно.

Вот где я застрял: я хочу сравнить определенный c столбец в wb1 с определенным c столбцом в wb2. Столбцы будут разной длины, и они будут разной длины в двух книгах. Кроме того, два открытых файла всегда будут иметь разные имена. Затем я хочу вставить ячейки из wb1, которые не отображаются в wb2, в столбец A wb3 на странице результатов. Я опубликую то, что у меня есть, я думаю, что я близок, но я могу полностью ошибаться в этом!

Заранее благодарю за помощь !!!

Option Explicit
Sub opening_multiple_file()

Dim i As Integer

'Opening File dialog box

With Application.FileDialog(msoFileDialogFilePicker)

    'Enabling multiple files select
    .AllowMultiSelect = True
    .Filters.Clear

    'Only Excel files can be selected
    .Filters.Add "Excel Files", "*.xls*"

    If .Show = True Then
        For i = 1 To .SelectedItems.Count
            'Opening selected file
            Workbooks.Open .SelectedItems(i)
        Next i
    End If

End With

Call save_as

End Sub

Sub save_as()

Dim wbk As Workbook
Set wbk = Workbooks("Anomaly List Compare Master.xlsm")
wbk.Sheets("Start").Activate

Dim FileName As Variant

'Displaying the saveas dialog box
FileName = Application.GetSaveAsFilename("Fault_Report_VEHICLENUMBER_MM_DD_YYYY", _
    "Excel files,*.xls*", 1, "Select your folder and filename")

'Save the workbook
ActiveWorkbook.SaveAs FileName

Call CreateSheet

End Sub

Sub CreateSheet()
    Dim ws As Worksheet
    With ThisWorkbook
        Set ws = .Sheets.Add(After:=.Sheets(.Sheets.Count))
        ws.Name = "Results"
    End With
Call Macro1
End Sub

Sub Macro1()

    Dim bothcolumns As Range, i As Integer
    Set bothcolumns = Selection
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim wb3 As Workbook
    For Each wb1 In Application.Workbooks
        If wb1.Name Like "SV_Report*" Then
            Set wb1 = wb1
            Exit For
        Else
            MsgBox "There is no SV_Report file opened.  Please try again..."
            End
        End If
    For Each wb2 In Application.Workbooks
        If wb2.Name Like "PPO*" Then
            Set wb2 = wb2
            Exit For
        Else
            MsgBox "There is no PPO file opened.  Please try again..."
            End
        End If
    For Each wb3 In Application.Workbooks
        If wb3.Name Like "Fault_Report*" Then
            Set wb3 = wb3
            Exit For
        Else
            MsgBox "There is no Fault_Report file opened.  Please try again..."
            End
        End If

    Application.ScreenUpdating = False

    For Each rngMyCell In wb1.Sheets("Test Fault Report").Range("A5:A500")
        lngArrayCount = lngArrayCount + 1
        ReDim Preserve varDataMatrix(1 To lngArrayCount)
        varDataMatrix(lngArrayCount) = rngMyCell
    Next rngMyCell

    lngArrayCount = 0

    For Each rngMyCell In wb2.Sheets("Static").Range("B2:B500")
        lngArrayCount = lngArrayCount + 1
        If rngMyCell.Value <> varDataMatrix(lngArrayCount) Then
           GoTo QuitRoutinue
        End If
    Next rngMyCell

    'If we get here both datasets have matched.
    Set wb1 = Nothing
    Set wb2 = Nothing
    Set wb3 = ActiveWorkbook.Sheets("Results")
    Application.ScreenUpdating = True
    Erase varDataMatrix() 'Deletes the varible contents, free some memory
    MsgBox "Data is the same.", vbInformation
    Exit Sub

QuitRoutinue:

    Set wb1 = Nothing
    Set wb2 = Nothing
    Set wb3 = ActiveWorkbook.Sheets("Results").Range("A2:A500")
    Paste varDataMatrix()
    Application.ScreenUpdating = True
    Erase varDataMatrix() 'Deletes the varible contents, free some memory

End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...