PDA

View Full Version : Copy Data From Closed Workbook Without Opening



jumbel
10-09-2008, 05:58 AM
I have the following code to do the same.


Option Explicit

Sub auto_open()

Dim FilePath$, Row&, Column&, Address$

Const FileName$ = "Date.xls"
Const SheetName$ = "Sheet2"
Const NumRows& = 1090
Const NumColumns& = 3
FilePath = ActiveWorkabook.Path & "\"


DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
For Row = 3 To NumRows
For Column = 1 To NumColumns
Address = Cells(Row, Column).Address
Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
Columns.AutoFit
Next Column
Next Row
ActiveWindow.DisplayZeros = False
End Sub


Private Function GetData(Path, File, Sheet, Address)
Dim Data$
Data = "'" & Path & "[" & File & "]" & Sheet & "'!" & _
Range(Address).Range("G2").Address(, , xlR1C1)
GetData = ExecuteExcel4Macro(Data)
End Function



But its taking very large amount of time to execute, I am confused as to why its taking so long. Anyone please let m know where i did wrong.

Kenneth Hobs
10-09-2008, 06:45 AM
http://vbaexpress.com/kb/getarticle.php?kb_id=286&PHPSESSID=279d5f78c087459f5a79619e3273662b (http://vbaexpress.com/forum/../kb/getarticle.php?kb_id=286&PHPSESSID=279d5f78c087459f5a79619e3273662b)

lucas
10-09-2008, 06:58 PM
Not sure without seeing the workbooks but:
Do you need to copy this many rows?
Const NumRows& = 1090

GTO
10-10-2008, 01:22 AM
...But its taking very large amount of time to execute, I am confused as to why its taking so long. Anyone please let m know where i did wrong.

Hello jumbel,

I'm zero on knowledge as to Excel 4.0 macros, so not sure if or how to get ExecuteExcel4Macro to return more than a cell at a time. That said, it is reading the second file once per cell, so you are reading the second file about 3260+ times; hence the lengthy execution time...

As you are grabbing a contiguous range, you could try the below as a comparison.

Dim FilePath$, Row&, Column&, Address$
Const FileName$ = "Date.xls"
Const SheetName$ = "Sheet2"
Const NumRows& = 1090
Const NumColumns& = 3
FilePath = ThisWorkbook.Path & "\"
DoEvents
Application.ScreenUpdating = False
If Dir(FilePath & FileName) = Empty Then
MsgBox "The file " & FileName & " was not found", , "File Doesn't Exist"
Exit Sub
End If
With ThisWorkbook.Worksheets("Sheet1")
.Range("A3:C1090").FormulaArray = "=[Date.xls]Sheet2!R4C7:R1091C9"
.Range("A3:C1090") = .Range("A3:C1090").Value
.Columns("A:C").AutoFit
End With
' For Row = 3 To NumRows
' For Column = 1 To NumColumns
' Address = Cells(Row, Column).Address
' Cells(Row, Column) = GetData(FilePath, FileName, SheetName, Address)
' Columns.AutoFit
' Next Column
' Next Row

ActiveWindow.DisplayZeros = False


Hope this helps :-)

Mark

OhGorgeous1
10-10-2008, 01:30 AM
Jumbel, not sure if this will help but it works quite quick for me (not sure either where the code came from in the first place though, it was passed onto myself via a work colleague)

Sub ImportDistricts()
Dim x As Long, z As Variant
Dim bk As Workbook, sh As Worksheet
Dim sh1 As Worksheet
Dim CurrentFileName As String

'
' Change the next line to reflect the proper
' name and workbook where the data will be
' consolidated
'
'turn off screen update
Application.ScreenUpdating = False
'Sheets("Data").Select
'Application.DisplayAlerts = False
'ActiveWindow.SelectedSheets.Delete
'Application.DisplayAlerts = True
'Sheets.Add
'ActiveSheet.Name = "Data"
'ActiveSheet.Move After:=Sheets(1)
'Sheets("DataTemplate").Select
'Cells.Select
'Selection.Copy
'Sheets("Data").Select
'Range("A1").Select
'ActiveSheet.Paste

Sheets("Data").Select
Cells.Select
Selection.ClearContents
'new
Sheets("Data").Select
Columns("A:AF").Select
Selection.ClearContents
'end new
Sheets("DataTemplate").Select
Rows("1:1").Select
Selection.Copy
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
CurrentFileName = ActiveWorkbook.Name

Set sh = Workbooks(CurrentFileName).Worksheets("Data")
z = Application.GetOpenFilename(fileFilter:= _
"Excel files (*.xls), *.xls", MultiSelect:=True)
If Not IsArray(z) Then
Sheets("Instructions").Select
MsgBox "Nothing selected, original data removed"
Exit Sub
End If
'Open loop for action to be taken on all selected workbooks.
For x = 1 To UBound(z)
'Open the workbook(s) that were selected.
Set bk = Workbooks.Open(z(x))
'Check if sheet FinalData exists
On Error Resume Next
Set sh1 = bk.Worksheets("FinalData")
On Error GoTo 0
' if it exists, copy the data
If Not sh1 Is Nothing Then
Sheets("FinalData").Select
Range("A2").Select
Set rng = sh1.Range(Selection, ActiveCell.SpecialCells(xlLastCell))
Set rng1 = sh.Cells(Rows.Count, 1).End(xlUp)(2)
rng.Copy
rng1.PasteSpecial xlPasteValuesAndNumberFormats
End If

'Close the District workbook without saving it.
Application.CutCopyMode = False
bk.Close False
Next x
'Copies Data sheet
Sheets("Data").Select
'replaces 9 with '9 to help with ordering or bands
Columns("I:I").Select
Selection.Replace What:="9", Replacement:="'9", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("A1").Select
Range("A1").CurrentRegion.Select
'Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Copy
Sheets("Data").Select
Range("A1").Select
ActiveSheet.Paste


'turn on screen update
Application.ScreenUpdating = True

Application.CutCopyMode = False
'Message box to inform user the job is complete.
MsgBox "You have successfully imported the Data.", 64, "Import Completed"
End Sub

jumbel
10-14-2008, 12:28 AM
@GTO, the code you gave is given a runtime error: unable to set the formularray property of the range class.

GTO
10-14-2008, 01:09 AM
Sorry 'bout that . I am on my 'slower than creeping death' / Flinstonian laptop, so give me a minute.

Let me confirm two things:

The workbook that you are extracting the data from is in the same sub-directory?

The ranges are contiguous 3 col x 1000 rows?

Thank you so much,

Mark

GTO
10-14-2008, 02:48 AM
Well... in the meantime, try this.

With ThisWorkbook.Worksheets("Sheet1")
.Range("A3:C1090").FormulaArray = "=[Date.xls]Sheet2!$A$3:$C$1090"
.Range("A3:C1090") = .Range("A3:C1090").Value
.Columns("A:C").AutoFit
End With


Regards,

Mark

jumbel
10-16-2008, 12:20 AM
Hey mark, it is working but not in the way I wanted it....when you run the with loop mentioned above, it is asking for the file name to be selected and then displays the values. I want this to be done behind the user, automatically get the values and the user has to just run the macro.

jumbel
10-16-2008, 12:20 AM
Sorry I forgot to change the filename, but still the runtime error exists

GTO
10-16-2008, 03:00 AM
Hey mark, it is working but not in the way I wanted it....when you run the with loop mentioned above, it is asking for the file name to be selected and then displays the values. I want this to be done behind the user, automatically get the values and the user has to just run the macro.

Greetings and Salutations Krish,

There should not be a loop. While I of course do not want you to post any proprietory or private information -

could you post:

1. (a) the two workbooks
OR
(b) two example workbooks, wherein said have similarly
constructed filenames and sheetnames (ie - spaces or not).

2. The path or similarly constructed paths to the two workbooks.

I would note that I do not have access to Excel 2007, though I cannot imagine this to be the cause. If possible, please save the example workbooks in 2003/prior format.

Thank you so much, and sorry this rather simple fullname (in conjunction w/Excel's rules to build the link) is giving us such fits.

@Ken: Thank you for the link, as this appears to answer my question as to - returning a range(array) of values in a single swipe.

Mark