Copying data between two Excel files
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
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
[/CODE]
Attachment | Size |
---|---|
Curve Creation Tool.xlsm | 261.55 KB |
Sale_Report.xlsx | 230.79 KB |
SOLVED: Copying data between two Excel files
See: http://www.mrexcel.com/forum/excel-questions/776959-copying-data-between...