Обновление таблицы из внешнего Excel VBA - PullRequest
Новая
       13

Обновление таблицы из внешнего Excel VBA

0 голосов
/ 01 октября 2018

Я уже некоторое время работаю над этим кодом, беря все, что могу, из других постов и учусь на ходу.Я новичок в VBA.Я пытаюсь обновить основную электронную таблицу из других таблиц Excel.Я написал код для проверки значения столбца C и, если он имеет значение в Master, которого нет в другом, выделите строку красным цветом.Если на другом листе есть значение, которого нет у мастера, вставляется вся строка и выделяется зеленым цветом.Часть, которую я не могу заставить работать, это как обновить существующие строки новой информацией, когда значение столбца C совпадает.Каждый раз, когда я пытаюсь, он все испортил.

Вот мой код: 

    Sub FindDifferences()

    Application.ScreenUpdating = False
    Dim cell As Range
    Dim cel1 As Range
    Dim cel2 As Range
    Dim wkb1 As Workbook
    Dim wkb2 As Workbook
    Dim wks1 As Worksheet
    Dim wks2 As Worksheet
    Dim lRow As Long
    Dim iCntr As Long
    Dim r1 As Range
    Dim r2 As Range
    Dim i As Integer
    Dim j As Integer
    Dim lastRow1 As Integer
    Dim lastRow2 As Integer
    Dim lastRow As Long
    Dim recRow As Long
    Dim p As Long
    Dim fCell As Range

    Set wkb1 = Workbooks.Open(Filename:="C:\Users\James.R.Dickerson\...\09-24-2018-2.xlsx.xlsm")
    Set wks1 = wkb1.Worksheets("Job List")
    Set wkb2 = ThisWorkbook
    Set wks2 = wkb2.Worksheets("Code 200 TECH ASSISTs")

    lRow = 200
    recRow = 1

    For iCntr = lRow To 1 Step -1
        If Cells(iCntr, 1).Interior.Color = RGB(156, 0, 6) Then
            Rows(iCntr).Delete
        End If
    Next

    With wks1
        Set r1 = .Range("C2", .Cells(.Rows.Count, .Columns("C:C").Column).End(xlUp))
    End With

    With wks2
        Set r2 = .Range("C2", .Cells(.Rows.Count, .Columns("C:C").Column).End(xlUp))
    End With

    lastRow1 = wks2.UsedRange.Rows.Count
    lastRow2 = wks1.UsedRange.Rows.Count

    For i = 1 To lastRow1
        For j = 1 To lastRow2
            If r2(i).Value <> "" Then 'This will omit blank cells at the end (in the event that the column lengths are not equal.
                If r1(j).Value = r2(i).Value Then
                    r2(i).EntireRow.Delete
                    r1(j).EntireRow.Copy
                    r2(i).EntireRow.Insert
                    r2(i).EntireRow.Interior.Color = RGB(255, 255, 255) 'White background
                    r2(i).EntireRow.Font.Color = RGB(0, 0, 0) 'Black font color
                    Application.CutCopyMode = False
                    Exit For
                Else
                    If InStr(1, r1(j).Value, r2(i).Value, vbTextCompare) > 0 Then
                        'You may notice in the above instr statement, I have used vbTextCompare instead of its numerical value, _
                        I find this much more reliable.
                        r2(i).EntireRow.Interior.Color = RGB(255, 255, 255) 'White background
                        r2(i).EntireRow.Font.Color = RGB(0, 0, 0) 'Black font color
                        Exit For
                    Else
                        r2(i).EntireRow.Interior.Color = RGB(156, 0, 6) 'Dark red background
                        r2(i).EntireRow.Font.Color = RGB(255, 199, 206) 'Light red font color
                    End If
                End If
            End If
        Next j
    Next i

    With wks1
        lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row

        For i = 2 To lastRow
            'See if item is in Master sheet
            Set fCell = wks2.Range("C:C").Find(what:=.Cells(i, "C").Value, lookat:=xlWhole, MatchCase:=False)

            If Not fCell Is Nothing Then
                'Record is already in master sheet
                recRow = fCell.Row
            Else
                'Need to move this to master sheet after last found record
                .Cells(i, "C").EntireRow.Copy
                wks2.Cells(recRow + 1, "C").EntireRow.Insert
                wks2.Cells(recRow + 1, "C").EntireRow.Interior.Color = RGB(0, 190, 8)
                recRow = recRow + 1
            End If
       Next i
    End With


    Application.CutCopyMode = False

    wkb1.Close
    Application.ScreenUpdating = True
    'ActiveWorkbook.Save
    End Sub

Обновление кода выше работает нормально, он просто пропускает несколько строк, и я не могу понять, почему,Любая помощь приветствуется.Спасибо.

1 Ответ

0 голосов
/ 02 октября 2018

Этот блок: 

.Cells(p, "C").EntireRow.Copy
wks2.Cells(p, "C").EntireRow.Delete
wks2.Cells(recRow1 + 1, "C").EntireRow.Insert

находится в неправильном порядке, поскольку .Delete очищает буфер копирования, поэтому вы вставляете пустую строку.Измените порядок команд следующим образом: 

wks2.Cells(p, "C").EntireRow.Delete
.Cells(p, "C").EntireRow.Copy
wks2.Cells(recRow1 + 1, "C").EntireRow.Insert

и будет лучше:)

...