2
\$\begingroup\$

I have this code that:

  1. Clears my worksheet from row 12 and onward in Workbook A
  2. Opens a new file Workbook B
  3. Copys the sheet to my Workbook A. and Close Workbook B
  4. Renames sheet in Workbook A
  5. Transfers data from New Sheet to another Tab.

This seems to take me 10 minutes+, it is roughly 35k Rows.

Is there a faster way of doing this?

Thanks.

    Sub Mainsub()
    
    Worksheets("Main Data").Rows("12:" & Rows.Count).ClearContents
    
    'Copy data from the CM File to Template
    Application.ScreenUpdating = False
    
    'Open CM file
    Set MainDataCM = Workbooks.Open(Sheets("Input").Range("B16") & Sheets("Input").Range("B19"))
    'Copy main data tab to EPM file workbook
    MainDataCM.Sheets("Main Data").Copy After:=ThisWorkbook.Sheets(1)
    'Close CM Comm file
    MainDataCM.Close SaveChanges:=False
    Application.ScreenUpdating = True
          
     
    
    Sheets("Main Data (2)").Name = "CM_MainData"
    
    Worksheets("CM_MainData").Visible = False
    
    'Read the CM_MainData tab and copy the required columns in the MainData tab
    Dim k As Long
    k = Sheets("CM_MainData").Range("A1", Sheets("CM_MainData").Range("A1").End(xlDown)).Rows.Count
    Debug.Print (k)
    
    i = 12
    j = 2
    
    While j <= k
        Sheets("Main Data").Range("A" & i) = Sheets("CM_MainData").Range("A" & j)
        Sheets("Main Data").Range("B" & i) = Sheets("CM_MainData").Range("B" & j)
        Sheets("Main Data").Range("C" & i) = Sheets("CM_MainData").Range("C" & j)
        Sheets("Main Data").Range("D" & i) = Sheets("CM_MainData").Range("D" & j)
        Sheets("Main Data").Range("E" & i) = Sheets("CM_MainData").Range("E" & j)
        Sheets("Main Data").Range("F" & i) = Sheets("CM_MainData").Range("F" & j)
        Sheets("Main Data").Range("G" & i) = Sheets("CM_MainData").Range("G" & j)
        Sheets("Main Data").Range("H" & i) = Sheets("CM_MainData").Range("H" & j)
        Sheets("Main Data").Range("I" & i) = Sheets("CM_MainData").Range("I" & j)
        Sheets("Main Data").Range("J" & i) = Sheets("CM_MainData").Range("J" & j)
        Sheets("Main Data").Range("K" & i) = Sheets("CM_MainData").Range("K" & j)
        Sheets("Main Data").Range("L" & i) = Sheets("CM_MainData").Range("L" & j)
        Sheets("Main Data").Range("M" & i) = Sheets("CM_MainData").Range("M" & j)
        Sheets("Main Data").Range("N" & i) = Sheets("CM_MainData").Range("N" & j)
        Sheets("Main Data").Range("O" & i) = Sheets("CM_MainData").Range("O" & j)
        Sheets("Main Data").Range("P" & i) = Sheets("CM_MainData").Range("P" & j)
    
        i = i + 1
        j = j + 1
    Wend
    
    Worksheets("Input").Activate
    Worksheets("Input").Select
    
    MsgBox "Step 1 Completed"

End Sub
\$\endgroup\$
1
\$\begingroup\$

Seems like instead of transferring, Copying the Data and using ThisWorkbook was able to get the job done easily.

Sub Mainsubtwo()

Call Reset
Worksheets("Main Data").Rows("12:" & Rows.Count).ClearContents


Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Open CM file
Set MainDataCM = Workbooks.Open(Sheets("Input").Range("B16") & Sheets("Input").Range("B19"))

With Sheets("Main Data")
lastrow = Sheets("Main Data").Range("A" & .Rows.Count).End(xlUp).Row
Sheets("Main Data").Range("A2:P" & lastrow).Copy
End With
'Paste into this workbook
ThisWorkbook.Sheets("Main Data").Range("A12").PasteSpecial xlPasteValues


'Close CM file
MainDataCM.Close SaveChanges:=False
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Worksheets("Input").Activate
Worksheets("Input").Select

MsgBox "Step 1 Completed"


End Sub
\$\endgroup\$
0
\$\begingroup\$

Copy a Range From One File to Another

  • s - Source (read from), d - Destination (written to)

  • The code is still far from perfect but may be more educational for you to primarily understand the 'concept' of qualifying the objects:

    Dim wb As Workbook: Set wb = ThisWorkbook ' continue using 'wb'
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1") ' continue using 'ws'
    Dim fCell As Range: Set fCell = ws.Range("A2") ' continue using 'fCell'
    Dim lCell As Range: Set lCell = ws.Cells(ws.Rows.Count, "A").End(xlUp)
    Dim rg As Range: Set rg = ws.Range(fCell, lCell) ' continue using 'rg'
    

    etc. (it's for a one-column range)

  • Copying by assignment is by far the most efficient way to copy values (only):

    Dim srg As Range: Set srg = Range("A1:D10")
    Dim dCell As Range: Set dCell = Range("F1")
    dCell.Resize(srg.Rows.Count, srg.Columns.Count).Value = srg.Value
    

    If you additionally do...

    Dim drg As Range: Set drg = dCell.Resize(srg.Rows.Count, srg.Columns.Count)
    Debug.Print drg.Address(0, 0)
    

    then the result (the address of the Destination Range) printed in the Immediate window will be F1:I10.

The Code

Option Explicit

Sub CopyMainData()
    
    ' Create a reference to the Destination Workbook.
    Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
    
    ' Retrieve Source Workbook Path and Name.
    Dim swbPath As String, swbName As String
    With dwb.Worksheets("Input")
        swbPath = .Range("B16").Value
        swbName = .Range("B19").Value
    End With
    
    Application.ScreenUpdating = False
    
    ' Declare the Source Workbook variable.
    Dim swb As Workbook
    
    ' Check if a workbook with the same name as the name of the Source Workbook
    ' is already open. If so, close it saving any changes (or not?).
    On Error Resume Next
    Set swb = Workbooks(swbName)
    On Error GoTo 0
    If Not swb Is Nothing Then
        swb.Close SaveChanges:=True
    End If
    
    ' Attempt to open the Source Workbook.
    On Error Resume Next
    Set swb = Workbooks.Open(swbPath & swbName)
    On Error GoTo 0
    If swb Is Nothing Then
        MsgBox "The Workbook doesn't exist."
        Exit Sub
    End If
    
    ' If you feel that the previous two code blocks (scenarios)
    ' are not necessary (ridiculous) then replace them with:
    'Set swb = Workbooks.Open(swbpath & swbName)
    
    ' The 'Call' keyword is considered deprecated.
    Reset ' Reset what? e.g. 'ResetData' or 'ResetMain' are better names.
    
    ' Create a reference to the Source Range.
    Dim srg As Range
    With swb.Worksheets("Main Data")
        Dim sLastRow As Long: sLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        Set srg = .Range("A2:P" & sLastRow)
    End With
    ' Maybe this would be more appropriate (make sure to test it):
'    With swb.Worksheets("Main Data").Range("A1").CurrentRegion
'        Set srg = .Resize(.Rows.Count - 1).Offset(1)
'    End With
    
    ' Calculate the rows count of the (same-sized) ranges.
    Dim rCount As Long: rCount = srg.Rows.Count
    
    ' Using the reference to the Destination First Row Range ('A12:P12')...
    With dwb.Worksheets("Main Data").Range("A12").Resize(, srg.Columns.Count)
        ' Create a reference to the Destination Range.
        Dim drg As Range: Set drg = .Resize(rCount)
        ' Copy the values of the Source Range to the Destination Range
        ' by 'assignment'.
        drg.Value = srg.Value
        ' Create a reference to the Destination Clear Range, the range
        ' below the Destination Range.
        Dim dcrg As Range
        Set dcrg = .Resize(dws.Rows.Count - .Row - rCount + 1).Offset(rCount)
        ' Clear the contents of the Destination Clear Range
        dcrg.ClearContents
    End With
    
    ' Save and close.
    swb.Close SaveChanges:=False
    'dwb.Save
    
    Application.ScreenUpdating = True
    
    MsgBox "Main data copied."

End Sub
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.