Скопируйте две таблицы в другую, заменяя текущие данные.

Question

Я использовал и изменил код из Вопрос . Он работает нормально, но есть один недостаток: если я отменил выбор диапазона или выбрал другую ячейку, чем A1, весь код попадает в ошибку 1004. Я также уверен, что у меня есть какая-то дополнительная часть кода.

Может кто-нибудь пересмотреть код и предложить исправление?

Sub TG_update()
Dim wb1 As Workbook, wb2 As Workbook, ws1Format As Worksheet, ws2Format As Worksheet, ws3Format As Worksheet, ws4Format As Worksheet
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set wb1 = ThisWorkbook
Set wb2 = Workbooks.Open("[add your path.xlsx]")
Set ws1Format = wb1.Sheets("SheetA1")
Set ws2Format = wb2.Sheets("SheetB1")
Set ws3Format = wb1.Sheets("SheetA2")
Set ws4Format = wb2.Sheets("SheetB2")

'' Copy the cells of the "Format" worksheet.
ws2Format.Cells.Copy


'' Paste cells to the sheet "Format".

wb1.Sheets("SheetA1").Paste

ws4Format.Cells.Copy

wb1.Sheets("SheetB1").Paste

wb2.Close False 'remove false if you want to be asked if the workbook shall be saved.
wb1.Sheets("Store").Activate
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "Date successfully updated"
End Sub

Спасибо.

Answer 1

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

Sub TG_update()
    ' 016

    Dim Wb As Workbook                      ' ThisWorkbook
    Dim WbS As Workbook                     ' Source
    Dim Ffn As String                       ' Full FileName
    Dim Ws As Worksheet
    Dim TabName() As String
    Dim i As Integer                        ' TabName index
    Dim n As Integer                        ' tab counter

    Set Wb = ThisWorkbook
    ' specify the workbook to be copied from: Full path and name
    Ffn = "F:\AWK PC\Drive E (Archive)\PVT Archive\Class 1\1-2018 (Jan 2020)\TXL 180719 Z Distance.xlsm"
    ' enumerate the sheet names in CSV format (sheets must exist in Wb)
    TabName = Split("SheetA1,SheetB1", ",")

    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With

    Set WbS = Workbooks.Open(Ffn)
    For i = 0 To UBound(TabName)
        On Error Resume Next                ' suppress error if worksheet isn't found
        WbS.Worksheets(TabName(i)).Copy After:=Wb.Worksheets(Wb.Worksheets.Count)
        If Err.Number = 0 Then
            n = n + 1
        End If
    Next i
    WbS.Close SaveChanges:=False

    On Error GoTo 0
    For i = 0 To UBound(TabName)
        For Each Ws In Wb.Worksheets
            If InStr(Ws.Name, TabName(i) & " (") = 1 Then
                Wb.Worksheets(TabName(i)).Delete
                Ws.Name = TabName(i)
            End If
        Next Ws
    Next i

    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With

    MsgBox n & " of " & i & " worksheets were successfully updated.", _
           vbInformation, "Action report"
End Sub

Имена объявлений, такие как Wb1, Wb2, Ws1, Ws2, SheetA1, SheetA2, представляют собой наказание, которое творческие программисты применяют к тем, кто приходит за ними, чтобы исправить их наспех придуманый код. Дайте вашему проекту VBA лучшую репутацию, добавив имена на ваших двух листах, которые позволяют их идентифицировать.