Поиск Копирования и замены в цикле Между двумя книгами Не работает

ProgramBox

Поиск Копирования и замены в цикле Между двумя книгами Не работает

Post author:admin
Запись опубликована:10 января, 2022
Post category:Вопросы по программированию

#excel #vba

Вопрос:

Я нахожусь в тупике с этим, исследовал как можно больше и все еще не могу понять, где я ошибаюсь. Ошибки, которые я продолжаю получать, похоже, связаны с тем, как я пытаюсь определить диапазоны, но я не понимаю, почему.

Я не могу поделиться рабочими книгами из-за конфиденциальности работы и защиты, но вот мой код:

 Sub Compare_DataSheet2021_ImportSheet()

Application.ScreenUpdating = False 'Switch off automatic screen updating
    MsgBox "Screen Updating Off", vbInformation

Sheets("Import Sheet").Visible = True 'Unhide the Import Sheet
    MsgBox "Unhidden Import Sheet", vbInformation
Sheets("Import Sheet").Unprotect "ImportSheet" 'Unprotect Import Sheet
     MsgBox "Unprotected Import Sheet", vbInformation

Dim wb As Workbook
    MsgBox "Opening Central Tracker", vbInformation
Set wb = Workbooks.Open("Y:GLOBALLEGALLCCTeamTest FolderCentral Tracker - Live.xlsm")

If wb.ReadOnly Then 'Check to see if the tracker is already open
ActiveWorkbook.Close
    MsgBox "Central Tracker is already in use. Speak to the Inbox Manager"
    Exit Sub
End If

Application.CutCopyMode = False 'This clears the clipboard
Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021").Activate

    MsgBox "Switching to Import Sheet", vbInformation
Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet").Activate

Dim i As Range 'Set a variable as a Ranage Data Type so that it can hold or store a range of values
Dim D As Range

    MsgBox "Setting i Range in Import Tracker", vbInformation
With Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet")
Workbooks("Import Tracker Test.xlsm").Worksheets("Import Sheet").Activate
Set i = Range("B2:B" amp; .Cells(.Rows.Count, "B").End(xlIp).Row)
    MsgBox "i Range Set", vbInformation
End With

    MsgBox "Setting D Range in Central Tracker", vbInformation
With Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021")

Workbooks("Central Tracker - Live.xlsm").Worksheets("Data 2021").Activate
Set D = .Range("B2:B" amp; .Cells(.Rows.Count, "B").End(xlIp).Row)
    MsgBox "D Range Set", vbInformation
End With

    MsgBox "Starting URN Match", vbInformation
For Each cell In i
'Look for a URN match in column B on both sheets
If i.Value = K.Value Then
MsgBox "URN Match Found", vbInformation
Sheets("Data 2021").Cells(D, 1).Value = Sheets("Import Sheet").Cells(i, 1).Value 'copy and replace Column A Incident Process
Sheets("Data 2021").Cells(D, 6).Value = Sheets("Import Sheet").Cells(i, 6).Value 'copy and replace Column F Status
Sheets("Data 2021").Cells(D, 9).Value = Sheets("Import Sheet").Cells(i, 9).Value 'copy and replace Column I Title
Sheets("Data 2021").Cells(D, 10).Value = Sheets("Import Sheet").Cells(i, 10).Value 'copy and replace Column J Business Contact
Sheets("Data 2021").Cells(D, 11).Value = Sheets("Import Sheet").Cells(i, 11).Value 'copy and replace Column K Submitting Team
Sheets("Data 2021").Cells(D, 13).Value = Sheets("Import Sheet").Cells(i, 13).Value 'copy and replace Column M Marketing
Sheets("Data 2021").Cells(D, 14).Value = Sheets("Import Sheet").Cells(i, 14).Value 'copy and replace Column N Product
Sheets("Data 2021").Cells(D, 15).Value = Sheets("Import Sheet").Cells(i, 15).Value 'copy and replace Column O Project Name
Sheets("Data 2021").Cells(D, 16).Value = Sheets("Import Sheet").Cells(i, 16).Value 'copy and replace Column P CONC
Sheets("Data 2021").Cells(D, 17).Value = Sheets("Import Sheet").Cells(i, 17).Value 'copy and replace Column Q Date Email Receieved
Sheets("Data 2021").Cells(D, 18).Value = Sheets("Import Sheet").Cells(i, 18).Value 'copy and replace Column R Time Receieved
Sheets("Data 2021").Cells(D, 23).Value = Sheets("Import Sheet").Cells(i, 23).Value 'copy and replace Column W Checklist
Sheets("Data 2021").Cells(D, 24).Value = Sheets("Import Sheet").Cells(i, 24).Value 'copy and replace Column X Rejected
Sheets("Data 2021").Cells(D, 25).Value = Sheets("Import Sheet").Cells(i, 25).Value 'copy and replace Column Y Allocated To
Sheets("Data 2021").Cells(D, 26).Value = Sheets("Import Sheet").Cells(i, 26).Value 'copy and replace Column Z Allocation Reason
Sheets("Data 2021").Cells(D, 27).Value = Sheets("Import Sheet").Cells(i, 27).Value 'copy and replace Column AA Allocation Date
Sheets("Data 2021").Cells(D, 28).Value = Sheets("Import Sheet").Cells(i, 28).Value 'copy and replace Column AB Reallocation
Sheets("Data 2021").Cells(D, 29).Value = Sheets("Import Sheet").Cells(i, 29).Value 'copy and replace Column AC Reallocation Date
Sheets("Data 2021").Cells(D, 30).Value = Sheets("Import Sheet").Cells(i, 30).Value 'copy and replace Column AD Reallocation Reason
Sheets("Data 2021").Cells(D, 35).Value = Sheets("Import Sheet").Cells(i, 35).Value 'copy and replace Column AI Date Business emailed
Sheets("Data 2021").Cells(D, 36).Value = Sheets("Import Sheet").Cells(i, 36).Value 'copy and replace Column AJ Time business emaailed
Sheets("Data 2021").Cells(D, 37).Value = Sheets("Import Sheet").Cells(i, 37).Value 'copy and replace Column AK Date Matter Closed
Sheets("Data 2021").Cells(D, 38).Value = Sheets("Import Sheet").Cells(i, 38).Value 'copy and replace Column AL Comments
Sheets("Data 2021").Cells(D, 40).Value = Sheets("Import Sheet").Cells(i, 40).Value 'copy and replace Column AN CM Risk
Sheets("Data 2021").Cells(D, 45).Value = Sheets("Import Sheet").Cells(i, 45).Value 'copy and replace Column AS Date Modified
    MsgBox "Completed Copy and Paste - starting to clear old data from Import Sheet", vbInformation
Sheets("Import Sheet").Cells(i, 1).Clear
Else
    MsgBox "URN Does Not Match", vbInformation
Exit For
End If

Next
    MsgBox LoopIndex amp; "Loop Count", vbInformation

Sheets("Import Sheet").Activate
Columns("A:AN").Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp

Sheets("Import Sheet").Protect "ImportSheet"
Sheets("Import Sheet").Visible = False
'Switch off automatic screen updating
Application.ScreenUpdating = True

    MsgBox "Good News! Your data has been transferred to the Central Tracker.", vbInformation

End Sub

1. Любая помощь будет очень признательна! Спасибо вам всем и каждому!

2. Пожалуйста, будьте конкретны в отношении сообщения об ошибке, которое вы получаете, и строки, которая его выдает.

3. Вероятно Range("B2:B" amp; .Cells... , добавьте . перед Range

4. End(xlIp) должно быть End(xlUp)

5. Где вы собираетесь K это If i.Value = K.Value сделать ?

Ответ №1:

Есть много проблем с кодом и дизайном. Слишком часто используется Activate и Select , больше полей для сообщений, чем кто-либо хочет видеть, и может использовать отступы для отслеживания вашего Ifs и Fors . Половину кода можно сократить. Лучше всего убедиться, что код работает, прежде чем добавлять дополнительные функции. Кроме того, не было возможности увеличить оба листа в вашем цикле. K не существовало, но D существовало. D не было никакого способа увеличить. Возможно, потребуется одна или две настройки, если я что-то пропустил, но это должно сработать, если я правильно понял.

 Sub Compare_DataSheet2021_ImportSheet()

    Application.ScreenUpdating = False 'Switch off automatic screen updating
    
    Dim wb1 As Workbook
    Dim wb2 As Workbook
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim LastRow As Long
    Dim x As Long
    
    
    Set wb1 = Workbooks("Import Tracker Test.xlsm")
    Set ws1 = wb1.Worksheets("Import Sheet")
    
    Set wb2 = Workbooks("Central Tracker - Live.xlsm")
    Set ws2 = wb2.Worksheets("Data 2021")
    
    ws1.Visible = True
    ws1.Unprotect
    
    Dim wb3 As Workbook
    Set wb3 = Workbooks.Open("Y:GLOBALLEGALLCCTeamTest FolderCentral Tracker - Live.xlsm")


    If wb.ReadOnly Then 'Check to see if the tracker is already open
        ActiveWorkbook.Close
        Exit Sub
    End If

    LastRow = ws1.Cells(Rows.Count, 2).End(xlUp).Row
    
    For x = 2 To LastRow
    'Look for a URN match in column B on both sheets
        If ws1.Cells(x, 2) = ws2.Cells(x, 2) Then

            ws2.Cells(x, 1).Value = ws1.Cells(x, 1).Value 'copy and replace Column A xncxxent Process
            ws2.Cells(x, 6).Value = ws1.Cells(x, 6).Value 'copy and replace Column F Status
            ws2.Cells(x, 9).Value = ws1.Cells(x, 9).Value 'copy and replace Column x Txtle
            ws2.Cells(x, 10).Value = ws1.Cells(x, 10).Value 'copy and replace Column J Busxness Contact
            ws2.Cells(x, 11).Value = ws1.Cells(x, 11).Value 'copy and replace Column K Submxttxng Team
            ws2.Cells(x, 13).Value = ws1.Cells(x, 13).Value 'copy and replace Column M Marketxng
            ws2.Cells(x, 14).Value = ws1.Cells(x, 14).Value 'copy and replace Column N Proxuct
            ws2.Cells(x, 15).Value = ws1.Cells(x, 15).Value 'copy and replace Column O Project Name
            ws2.Cells(x, 16).Value = ws1.Cells(x, 16).Value 'copy and replace Column P CONC
            ws2.Cells(x, 17).Value = ws1.Cells(x, 17).Value 'copy and replace Column Q xate Emaxl Recexevex
            ws2.Cells(x, 18).Value = ws1.Cells(x, 18).Value 'copy and replace Column R Txme Recexevex
            ws2.Cells(x, 23).Value = ws1.Cells(x, 23).Value 'copy and replace Column W Checklxst
            ws2.Cells(x, 24).Value = ws1.Cells(x, 24).Value 'copy and replace Column X Rejectex
            ws2.Cells(x, 25).Value = ws1.Cells(x, 25).Value 'copy and replace Column Y Allocatex To
            ws2.Cells(x, 26).Value = ws1.Cells(x, 26).Value 'copy and replace Column Z Allocatxon Reason
            ws2.Cells(x, 27).Value = ws1.Cells(x, 27).Value 'copy and replace Column AA Allocatxon xate
            ws2.Cells(x, 28).Value = ws1.Cells(x, 28).Value 'copy and replace Column AB Reallocatxon
            ws2.Cells(x, 29).Value = ws1.Cells(x, 29).Value 'copy and replace Column AC Reallocatxon xate
            ws2.Cells(x, 30).Value = ws1.Cells(x, 30).Value 'copy and replace Column Ax Reallocatxon Reason
            ws2.Cells(x, 35).Value = ws1.Cells(x, 35).Value 'copy and replace Column Ax xate Busxness emaxlex
            ws2.Cells(x, 36).Value = ws1.Cells(x, 36).Value 'copy and replace Column AJ Txme busxness emaaxlex
            ws2.Cells(x, 37).Value = ws1.Cells(x, 37).Value 'copy and replace Column AK xate Matter Closex
            ws2.Cells(x, 38).Value = ws1.Cells(x, 38).Value 'copy and replace Column AL Comments
            ws2.Cells(x, 40).Value = ws1.Cells(x, 40).Value 'copy and replace Column AN CM Rxsk
            ws2.Cells(x, 45).Value = ws1.Cells(x, 45).Value 'copy and replace Column AS xate Moxxfxex
        
            ws1.Cells(x, 1).Clear
            'Else ---left this in here commented.  You don't want to exit if you only get one mismatch right?
                'MsgBox "URN Does Not Match", vbInformation
                'Exit For
        End If

    Next
    
    With ws1
        .Columns("A:AN").SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
        .Protect "ImportSheet"
        .Visible = False
    End With

    Application.ScreenUpdating = True

    MsgBox "Good News! Your data has been transferred to the Central Tracker.", vbInformation

End Sub

1. Большое вам спасибо за вашу помощь, Даррелл Х. — с парой незначительных настроек это сработало очень хорошо:

2. Как мне теперь сделать так, чтобы в случае отсутствия совпадения данные добавлялись в следующую пустую строку? и раздел, посвященный удалению старых данных из листа импорта, похоже, не работал.

3. И еще — последнее дело! Как мне настроить его на бездействие, если центральный трекер уже открыт?

Метки: Поиск Копирования и замены в цикле Между двумя книгами Не работает