Removing Screen flicker and adding efficiency to Copy Paste Macro

Jn12345 

Yes, that makes sense. The goal is to avoid unintentional data loss when the source workbook is already open. This macro has the change to check if the source workbook is already open before continuing with the rest of the logic.

Sub OptimizedCopyPaste()
    Dim wbSource As Workbook
    Dim wbDest As Workbook
    Dim wsSource As Worksheet
    Dim wsDest As Worksheet
    Dim DataRange As Range
    Dim DestRange As Range
    Dim FileToOpen As Variant
    Dim TempArray() As Variant
    Dim IsAlreadyOpen As Boolean

    ' Disable screen updating, events, and alerts to prevent flickering
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False

    ' Set the destination workbook and worksheet (the one with the button)
    Set wbDest = ThisWorkbook
    Set wsDest = wbDest.Sheets("Sheet1") ' Adjust to your destination sheet

    ' Prompt user to select the source workbook
    FileToOpen = Application.GetOpenFilename("Excel Files (*.xlsm), *.xlsm")
    If FileToOpen = False Then Exit Sub ' User canceled

    ' Check if the source workbook is already open
    IsAlreadyOpen = IsWorkbookOpen(FileToOpen)

    ' Open the workbook only if it's not already open
    If Not IsAlreadyOpen Then
        Set wbSource = Workbooks.Open(FileToOpen)
    Else
        Set wbSource = Workbooks(FileNameFromPath(FileToOpen))
    End If

    Set wsSource = wbSource.Sheets("Sheet1") ' Adjust to your source sheet

    ' Define the range you want to copy (adjust as needed)
    Set DataRange = wsSource.Range("A1:D10") ' Adjust the range you want to copy

    ' Load the data into an array for faster processing
    TempArray = DataRange.Value

    ' Define the destination range
    Set DestRange = wsDest.Range("A1").Resize(UBound(TempArray, 1), UBound(TempArray, 2))

    ' Transfer the data from the array to the destination
    DestRange.Value = TempArray

    ' Close the source workbook without saving if it was opened by the macro
    If Not IsAlreadyOpen Then
        wbSource.Close SaveChanges:=False
    End If

    ' Re-enable screen updating, events, and alerts
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

    MsgBox "Data transfer completed!", vbInformation
End Sub

' Function to check if a workbook is already open
Function IsWorkbookOpen(workbookName As String) As Boolean
    Dim wb As Workbook
    IsWorkbookOpen = False

    ' Loop through open workbooks to see if the name matches
    For Each wb In Workbooks
        If wb.FullName = workbookName Then
            IsWorkbookOpen = True
            Exit Function
        End If
    Next wb
End Function

' Function to get just the file name from a full path
Function FileNameFromPath(fullPath As String) As String
    FileNameFromPath = Mid(fullPath, InStrRev(fullPath, "\") + 1)
End Function

The VBA code is untested and serves as an example only, please backup your file in advance as a precaution.

My answers are voluntary and without guarantee!

Hope this will help you.

Was the answer useful? Mark as best response and Like it!

This will help all forum participants.