Forum Discussion
Removing Screen flicker and adding efficiency to Copy Paste Macro
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 FunctionThe 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.
NikolinoDE Thanks for your help! It helped a lot. So i have another part of my code that updates from tables in one workbook into the destination workbook and I have noticed that when I do something similar to what you showed me, everything works except since the tables can be varying in size from source to destination that sometimes If the source table isnt the same size as the destination then I either get values going outside of the table and not making the table bigger (if destination table size is smaller in row count) and if the destination table is bigger than the source table then I get #N/A in the blank cells in the table (SEE ATTACHED). I didnt get this issue when I was doing copy paste but when I copy paste I then get a big screen flicker so im trying to make this work. Please see attached and If there is any insight into how to make it work that would solve everything!
This is the code:
Sub ImportMasterData()
Dim OpenBook As Workbook
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
Set OpenBook = Application.Workbooks.Open(Environ("userprofile") & "\360 NDE Inc. Dropbox\`Technician Reference\~Source Codes\SourceCodes")
'Clear Contents from the tables
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_Equipment").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_ConsumablesTable").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_AcceptanceStandards").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_InHouseProcedures").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_OurTechs").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_ClientsAndAddresses").DataBodyRange.ClearContents
ThisWorkbook.Worksheets("HIDDEN TABLES").ListObjects("TABLE_ClientPersonnel").DataBodyRange.ClearContents
'Put new values into the new tables
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_Equipment[Equipment Sub Category]:TABLE_Equipment[Thickness (mm)]").Value = OpenBook.Sheets("Equipment").Range("MasterEquipmentListTable[Equipment Sub Category]:MasterEquipmentListTable[Thickness (mm)]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_ConsumablesTable[NDE Method]:TABLE_ConsumablesTable[Product Number]").Value = OpenBook.Sheets("Consumables").Range("ConsumablesTable[NDE Method]:ConsumablesTable[Product Number]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_AcceptanceStandards[Acceptance Standard(s):]:TABLE_AcceptanceStandards[Acceptance Standards Revs]").Value = OpenBook.Sheets("Procedures & Codes").Range("AcceptanceStandardsTable[Acceptance Standard(s):]:AcceptanceStandardsTable[Acceptance Standards Revs]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_InHouseProcedures[NDE Method:]:TABLE_InHouseProcedures[Technique Rev]").Value = OpenBook.Sheets("Procedures & Codes").Range("ProceduresAndTechniquesTable[NDE METHOD:]:ProceduresAndTechniquesTable[Technique Rev]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_OurTechs[Lead Techs]:TABLE_OurTechs[CWB Expiry]").Value = OpenBook.Sheets("Personnel & Contact Info").Range("OurTechsTable[Lead Techs]:OurTechsTable[CWB Expiry]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_ClientsAndAddresses[Unique Clients]:TABLE_ClientsAndAddresses[PostalZIP]").Value = OpenBook.Sheets("Personnel & Contact Info").Range("ClientsAndAddresses[Unique Clients]:ClientsAndAddresses[PostalZIP]").Value
ThisWorkbook.Worksheets("HIDDEN TABLES").Range("TABLE_ClientPersonnel[Client Personnel & Excavation Contractor Company Name]:TABLE_ClientPersonnel[Position]").Value = OpenBook.Sheets("Personnel & Contact Info").Range("ClientPersonnel[Client Personnel & Excavation Contractor Company Name]:ClientPersonnel[Position]").Value
OpenBook.Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
