Copying data between two Excel files

D

dorindanci

New Member
Joined
May 5, 2014
Messages
16
Hi,

I am trying to copy several filtered columns from an Excel file to another.
I have the code to do this, but I think it needs some refinement (or re-written from scratch?!).

I think that when I copy data from a column (source file) to another column (destination file), it copies the entire column (row 1 to row 1,048,576) and then the calculations in the destination file are slow (the processors are working hard even when I do only banal tasks like filtering or data input).

Is there a way so when I copy data, only the visible and non-blank data is copied, OR a way for the code to determine the entire range of the source spreadsheet with data to be copied, and then only those cells are being copied?

ANY OTHER APPROACH IS WELCOMED:nya:
<v:shapetype id="_x0000_t75" stroked="f" filled="f" path="m@4@5l@4@11@9@11@9@5xe" o:preferrelative="t" o:spt="75" coordsize="21600,21600"><v:stroke joinstyle="miter"><v:formulas><v:f eqn="if lineDrawn pixelLineWidth 0"><v:f eqn="sum @0 1 0"><v:f eqn="sum 0 0 @1"><v:f eqn="prod @2 1 2"><v:f eqn="prod @3 21600 pixelWidth"><v:f eqn="prod @3 21600 pixelHeight"><v:f eqn="sum @0 0 1"><v:f eqn="prod @6 1 2"><v:f eqn="prod @7 21600 pixelWidth"><v:f eqn="sum @8 21600 0"><v:f eqn="prod @7 21600 pixelHeight"><v:f eqn="sum @10 21600 0"></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:f></v:formulas><v:path o:connecttype="rect" gradientshapeok="t" o:extrusionok="f"><o:lock aspectratio="t" v:ext="edit"></o:lock></v:path></v:stroke></v:shapetype><v:shape style="width: 11.25pt; height: 11.25pt; visibility: visible; mso-wrap-style: square;" id="Picture_x0020_1" type="#_x0000_t75" alt="http://www.mrexcel.com/forum/images/smilies/icon_smile.gif" o:spid="_x0000_i1025"><v:imagedata o:title="icon_smile" src="file:///C:\Users\ddanci\AppData\Local\Temp\2\msohtmlclip1\01\clip_image001.gif"></v:imagedata></v:shape>
Source file: Sale_Report.xlsx (Detail tab)
Destination file: Curve Creation Tool.xlsm
- Input tab: Import Sales button (macro)
- Data tab: data copied from Detail spreasdsheet

If you need the files, send me an email to holograful@gmail.com, and I will attach them.

Thank you.

Issues:
To refine or re-write this:
'Clear Data in the Curve Creation Tool
wShtData.Range("A2:S2000").Clear
wShtData.Range("U2:X2000").Clear
wShtData.Range("Z2:AO2000").Clear

To refine or re-write this:
'Copy data from Extract to Curve Creation Tool
With Workbooks(FileName)
.Sheets("Detail").Columns("A:A").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("A1")
.Sheets("Detail").Columns("C:K").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("B1")
.Sheets("Detail").Columns("S:S").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("K1")
.Sheets("Detail").Columns("L:M").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("L1")
.Sheets("Detail").Columns("Z:AC").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("z1")
.Sheets("Detail").Columns("AD:AG").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("U1")
.Sheets("Detail").Columns("AH:AH").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AE1")
.Sheets("Detail").Columns("AI:AI").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AD1")
.Sheets("Detail").Columns("AJ:AO").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AF1")
.Sheets("Detail").Columns("AZ:BA").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AL1")
.Sheets("Detail").Columns("BE:BE").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AN1")
.Sheets("Detail").Columns("BI:BI").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AO1")
.Sheets("Detail").Columns("BK:BM").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("Q1")
.Sheets("Detail").Columns("AP:AR").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("N1")
End With

See the entire code below:
Code: 
'Option Explicit
Sub ImportSales()
'
'ImportSales Macro
Application.EnableEvents = False
Application.EnableAnimations = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim wbkCurveCreationTool As Workbook
Dim wShtData As Worksheet
Set wbkCurveCreationTool = Workbooks("Curve Creation Tool.xlsm")
Set wShtData = wbkCurveCreationTool.Sheets("Data")
'Clear Data in the Curve Creation Tool
wShtData.Range("A2:S2000").Clear
wShtData.Range("U2:X2000").Clear
wShtData.Range("Z2:AO2000").Clear
MsgBox "Importing may take around 2 minutes"
' use the file open dialog to find the file
FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="Excel Files *.xls? (*.xls?),")
If FileToOpen = False Then
    MsgBox "No file specified.", vbExclamation, "Please Try Again"
Exit Sub
Else
    Workbooks.Open FileName:=FileToOpen
    Range("A1").Select
End If
FileName = Mid(FileToOpen, InStrRev(FileToOpen, "\") + 1)
'Dim FileName1 As Workbooks
'Dim wShtDetail As Worksheet
'Set FileName1 = Workbooks(FileName)
'Set wShtDetail = FileName.Sheets("Detail")
'Copy data from Extract to Curve Creation Tool
With Workbooks(FileName)
    .Sheets("Detail").Columns("A:A").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("A1")
    .Sheets("Detail").Columns("C:K").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("B1")
    .Sheets("Detail").Columns("S:S").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("K1")
    .Sheets("Detail").Columns("L:M").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("L1")
    .Sheets("Detail").Columns("Z:AC").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("z1")
    .Sheets("Detail").Columns("AD:AG").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("U1")
    .Sheets("Detail").Columns("AH:AH").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AE1")
    .Sheets("Detail").Columns("AI:AI").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AD1")
    .Sheets("Detail").Columns("AJ:AO").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AF1")
    .Sheets("Detail").Columns("AZ:BA").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AL1")
    .Sheets("Detail").Columns("BE:BE").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AN1")
    .Sheets("Detail").Columns("BI:BI").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AO1")
    .Sheets("Detail").Columns("BK:BM").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("Q1")
    .Sheets("Detail").Columns("AP:AR").SpecialCells(xlCellTypeVisible).Copy wShtData.Range("N1")
End With
    'Close extract
    Workbooks(FileName).Close False
    
    'Format Sale Date field
    wShtData.Range("AL:AL").NumberFormat = "dd/mm/yyyy"
    
    Application.Goto Worksheets("Data").Range("A1"), True
    
    'Save Curve Creation Tool
    ThisWorkbook.Save
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.EnableAnimations = True
End Sub
 

Excel Facts

Which lookup functions find a value equal or greater than the lookup value?
MATCH uses -1 to find larger value (lookup table must be sorted ZA). XLOOKUP uses 1 to find values greater and does not need to be sorted.
Sort by date Sort by votes
I don't have Excel at the moment, so this is untested....
try
Code: 
'Option Explicit
Sub ImportSales()
'
'ImportSales Macro
Application.EnableEvents = False
Application.EnableAnimations = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim wbkCurveCreationTool As Workbook, lr As Long, lr2 As Long
Dim wShtData As Worksheet
Set wbkCurveCreationTool = Workbooks("Curve Creation Tool.xlsm")
Set wShtData = wbkCurveCreationTool.Sheets("Data")
'Clear Data in the Curve Creation Tool
lr = Sheets(wShtData).Cells(Rows.Count, "A").End(xlUp).Row
wShtData.Range("A2:S" & lr).Clear
wShtData.Range("U2:X" & lr).Clear
wShtData.Range("Z2:AO" & lr).Clear
MsgBox "Importing may take around 2 minutes"
' use the file open dialog to find the file
FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="Excel Files *.xls? (*.xls?),")
If FileToOpen = False Then
    MsgBox "No file specified.", vbExclamation, "Please Try Again"
Exit Sub
Else
    Workbooks.Open Filename:=FileToOpen
    Range("A1").Select
End If
Filename = Mid(FileToOpen, InStrRev(FileToOpen, "\") + 1)
'Dim FileName1 As Workbooks
'Dim wShtDetail As Worksheet
'Set FileName1 = Workbooks(FileName)
'Set wShtDetail = FileName.Sheets("Detail")
'Copy data from Extract to Curve Creation Tool
lr2 = Cells(Rows.Count, "A").End(xlUp).Row
With Workbooks(Filename)
    .Sheets("Detail").Range("A1:A" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("A1")
    .Sheets("Detail").Range("C1:K" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("B1")
    .Sheets("Detail").Range("S1:S" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("K1")
    .Sheets("Detail").Range("L1:M" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("L1")
    .Sheets("Detail").Range("Z1:AC" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("z1")
    .Sheets("Detail").Range("AD1:AG" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("U1")
    .Sheets("Detail").Range("AH1:AH" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AE1")
    .Sheets("Detail").Range("AI1:AI" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AD1")
    .Sheets("Detail").Range("AJ1:AO" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AF1")
    .Sheets("Detail").CRange("AZ1:BA" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AL1")
    .Sheets("Detail").Range("BE1:BE" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AN1")
    .Sheets("Detail").Range("BI1:BI" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AO1")
    .Sheets("Detail").Range("BK1:BM" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("Q1")
    .Sheets("Detail").Range("AP1:AR" & lr2).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("N1")
End With
    'Close extract
    Workbooks(Filename).Close False
    
    'Format Sale Date field
    wShtData.Range("AL1:AL" & lr).NumberFormat = "dd/mm/yyyy"
    
    Application.Goto Worksheets("Data").Range("A1"), True
    
    'Save Curve Creation Tool
    ThisWorkbook.Save
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.EnableAnimations = True
End Sub
 
Upvote 0
SOLVED: Copying data between two Excel files

Thanks to some of the forum's members (especially Michael M), see below the final macro for copying data between two Excel files. Copies very fast the non-balnk cells and it calculates fast after importing.

Code: 
Option Explicit
Sub ImportSales()
'
'ImportSales Macro
Application.EnableEvents = False
Application.EnableAnimations = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim FileToOpen
Dim FileName As String
Dim lrData As Long, lrDetail As Long
Dim wbkCurveCreationTool As Workbook
Dim wShtData As Worksheet
Set wbkCurveCreationTool = Workbooks("Curve Creation Tool.xlsm")
Set wShtData = wbkCurveCreationTool.Sheets("Data")
'Autofilter OFF
If ActiveSheet.AutoFilterMode Then
    If ActiveSheet.FilterMode Then
        ActiveSheet.ShowAllData
    End If
ElseIf ActiveSheet.FilterMode Then
    ActiveSheet.ShowAllData
End If
'Get the last row in the Data sheet (Curve Creation Tool)
lrData = wShtData.Range("B" & Rows.Count).End(xlUp).Row
MsgBox "Last row in Data spreadsheet is " & lrData
'Clear Data in the Curve Creation Tool
wShtData.Range("A2:T2" & lrData).Clear
wShtData.Range("V2:Z2" & lrData).Clear
wShtData.Range("AB2:AR2" & lrData).Clear
MsgBox ("Import only an extract Excel file." & vbNewLine & "It will take less than 30 seconds.")
'Use the file open dialog to find the file
FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="Excel Files *.xls? (*.xls?),")
If FileToOpen = False Then
    MsgBox "No file specified.", vbExclamation, "Please Try Again"
    Application.Calculate
Exit Sub
Else
    Workbooks.Open FileName:=FileToOpen
    Range("A1").Select
End If
FileName = Mid(FileToOpen, InStrRev(FileToOpen, "\") + 1)
'Dim FileName1 As Workbooks
'Dim wShtDetail As Worksheet
'Set FileName1 = Workbooks(FileName)
'Set wShtDetail = FileName.Sheets("Detail")
'Get the last row in the Detail sheet (Extract file)
lrDetail = Range("A" & Rows.Count).End(xlUp).Row
MsgBox "Last row in Detail spreadsheet is " & lrDetail
'Copy data from Extract to Curve Creation Tool
With Workbooks(FileName)
    .Sheets("Detail").Range("A2:A" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("B2")
    .Sheets("Detail").Range("C2:K" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("C2")
    .Sheets("Detail").Range("S2:S" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("L2")
    .Sheets("Detail").Range("L2:M" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("M2")
    .Sheets("Detail").Range("Y2:AC" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AB2")
    .Sheets("Detail").Range("AD2:AH" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("V2")
    .Sheets("Detail").Range("AI2:AI" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AH2")
    .Sheets("Detail").Range("AJ2:AJ" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AG2")
    .Sheets("Detail").Range("AK2:AP" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AI2")
    .Sheets("Detail").Range("BA2:BB" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AO2")
    .Sheets("Detail").Range("BF2:BF" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AQ2")
    .Sheets("Detail").Range("BJ2:BJ" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("AR2")
    .Sheets("Detail").Range("BL2:BN" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("R2")
    .Sheets("Detail").Range("AQ2:AS" & lrDetail).SpecialCells(xlCellTypeVisible).Copy wShtData.Range("O2")
End With
    
    'Close extract
    Workbooks(FileName).Close False
    
    'Format Sale Date
    wShtData.Range("AO2:AO" & lrData).NumberFormat = "dd-mmm-yy"
    
    'Populate empty assessment cells with zero
    Dim cell As Range
    For Each cell In wShtData.Range("O2:T2" & lrData)
        If Len(cell.Value) = 0 Then
            cell.Value = 0
        End If
    Next
    
    Application.Goto Worksheets("Data").Range("A1"), True
    
    'Save Curve Creation Tool
    ThisWorkbook.Save
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.EnableAnimations = True
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
EXCEL VBA - help to copy filtered data from one workbook to multiple new workbooks and save code.
Replies
2
Views
404
Jordan2
J
Kristylee0228
  • Question Question
Populating Cell based on File Name and using a List
Replies
0
Views
415
Kristylee0228
Kristylee0228
R
  • Solved
Excel VBA to filter by unique value, copy paste into new workbook and save
Replies
2
Views
762
rittersportyummy
R
S
  • Solved
Copy only the data shown with adding a blank row between all copied rows
Replies
4
Views
599
sofas
S
I
  • Question Question
Copy and Paste Filtered data from another file & autofill month in pasted data
Replies
0
Views
689
Iniyavan
I

Forum statistics

Threads
1,223,374
Messages
6,171,710
Members
452,418
Latest member
kennettz

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top