VBA Сравнить строки на двух листах и ​​добавить недостающие данные - PullRequest
Новая
       27

VBA Сравнить строки на двух листах и ​​добавить недостающие данные

0 голосов
/ 03 августа 2020

Я хотел бы сравнить два точных листа, которые хранятся в двух разных книгах.

Я бы хотел, чтобы данные с 1-го листа (см. Столбец с синим идентификатором - KDws) отображались на 2-м листе (зеленый идентификатор - KDwsMain), который является основным файлом. Не хотелось бы, чтобы дубликаты отображались в основном файле.

Есть идеи, как улучшить код ниже?

enter image description here введите описание изображения здесь

Мой фрагмент кода: 

Sub CompareKDandDetailsView()

Dim wb As Workbook
Dim wbMain As Workbook
Set wb = ActiveWorkbook
Dim LastR As Long, LastR_main As Long
Dim i As Integer, k As Integer, j As Integer

Dim KDws As Worksheet, KDwsMain As Worksheet
Dim strFile As String
  
Set KDws = wb.Worksheets("KD")
LastR = KDws.Cells(Rows.Count, 1).End(xlUp).Row

'open Target file
MsgBox "Select the main file to upload your changes."
strFile = Application.GetOpenFilename()
Workbooks.Open (strFile)

Set KDwsMain = wbMain.Worksheets("KD")
LastR_main = KDwsMain.Cells(Rows.Count, 1).End(xlUp).Row
'-----------------------------

'-----------------------------
k = KDwsMain.UsedRange.Rows.Count 'last used row of the first worksheet
j = KDws.UsedRange.Rows.Count 'last used row of the second worksheet

For i = 2 To k 'Loop through the used rows of the first worksheet
    'use "countIf" to quickly check if the value exists in the given range
    'This way we don't have to loop through the second worksheet each time
     If Application.WorksheetFunction.CountIf(KDwsMain.Range(KDwsMain.Cells(2, 1), KDwsMain.Cells(j, 1)), KDws.Cells(i, 1).Value) > 0 Then
        'do nothing
    Else
        LastR_main = KDwsMain.Cells(Rows.Count, 1).End(xlUp).Row
        KDwsMain.Cells(LastR_main + 1, 1).Value = KDws.Cells(i, 1)
        KDwsMain.Cells(LastR_main + 1, 2).Value = KDws.Cells(i, 2)
    End If
Next i

End Sub

1 Ответ

1 голос
/ 03 августа 2020

Попробуйте следующий код, пожалуйста. Не тестировал, но думаю должно работать: 

Sub CompareKDandDetailsView()
Dim wb As Workbook, wbMain As Workbook

Set wb = ActiveWorkbook
Dim LastR As Long, LastR_main As Long, lastCol As Long
Dim i As Long

Dim KDws As Worksheet, KDwsMain As Worksheet
Dim strFile As String
  
Set KDws = wb.Worksheets("KD")
LastR = KDws.cells(Rows.count, 1).End(xlUp).Row
lastCol = KDws.cells(1, Columns.count).End(xlToLeft).Column
'open Target file
MsgBox "Select the main file to upload your changes."
strFile = Application.GetOpenFilename()
Set wbMain = Workbooks.Open(strFile)

Set KDwsMain = wbMain.Worksheets("KD")
'-----------------------------

 For i = 2 To LastR 'Loop through the used rows of the first worksheet
    'use "countIf" to quickly check if the value exists in the given range
    'This way we don't have to loop through the second worksheet each time
     LastR_main = KDwsMain.cells(Rows.count, 1).End(xlUp).Row + 1
     If Application.WorksheetFunction.CountIf(KDwsMain.Range("A2:A" & LastR_main), _
                                                       KDws.Range("A" & i)) = 0 Then

        KDwsMain.Range(KDwsMain.cells(LastR_main, "A"), KDwsMain.cells(LastR_main, lastCol)).Value = _
                                            KDws.Range(KDws.cells(i, 1), KDws.cells(i, lastCol)).Value
    End If
 Next i
End Sub
...