Forum Discussion

Jn12345's avatar
Jn12345
Brass Contributor
Oct 18, 2024

Removing Screen flicker and adding efficiency to Copy Paste Macro

Hello smart excel users,   I have a macro that I've made that pulls data from other reports. I typically get to use .range = .value2 because I use table 99% of the time, however, in the case of my ...
excel
Macros and VBA
Jn12345's avatar
Jn12345
Brass Contributor
Oct 20, 2024
Actually I think the perfect thing to do would be to make it open and close without saving if the file is closed prior to opening it, and remain open without saving if the file is already open. Does that make sense?
  • NikolinoDE's avatar
    NikolinoDE
    Gold Contributor
    Oct 20, 2024

    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.

    • Jn12345's avatar
      Jn12345
      Brass Contributor
      Oct 24, 2024

      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

    • Jn12345's avatar
      Jn12345
      Brass Contributor
      Oct 20, 2024
      There seems to be a mis match error and unfortunately I am not good enough at VBA to figure it out. But i will keep trying.

      Another thing, In this code will i be able to add multiple ranges to the set as Data range portion?

Resources