Copying data from several spreadsheets into a new spreadsheet

[Mike Magill]

Hi,

I'm pretty much a novice at Excel macros so forgive me if I don't
understand your responses the first time.

I want to write a macro that will open a variable number of
spreadsheets in a specific folder and copy a range of a variable
number of rows from each spreadsheet into a single new spreadsheet
with each range being copied immediately below the previous range.

Each originating spreadsheet name will start with the date (e.g.
2009-03-31 Rest of spreadsheet name.xls) so I want the macro to open
all spreadsheets in the folder starting with '2009-03-31'. I've
already got a bit of script that I can use to allow the user to
specify the data and the folder in which these spreadsheets live.

The data in each originating spreadsheet is in rows and the actual
data to be copied is determined by an Autofilter in field 30 being
"x". The number of rows could 1 to 1000.

Any help you can provide will be greatly appreciated.

Many thanks,

 

[Joel]

try this

Sub MakeSummary()

Set SumSht = ThisWorkbook.Sheets("Summary")


'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFolderPicker)

'Use a With...End With block to reference the FileDialog object.
With fd

'Set the initial path to the C:\ drive.
.InitialFileName = "C:\Documents and Settings\All\My Documents"

'Use the Show method to display the File Picker dialog box and
return the user's action.
'If the user presses the button...
If .Show = -1 Then
Folder = .SelectedItems.Item(1)

'If the user presses Cancel...
Else
MsgBox ("Cannot open Folder - Exiting Macro")
Exit Sub
End If
End With

'Set the object variable to Nothing.
Set fd = Nothing

If Right(Folder, 1) <> "\" Then
Folder = Folder & "\"
End If

FName = Dir(Folder & "*.xls*")
Do While FName <> ""
Set bk = Workbooks.Open(Folder & FName)
For Each sht In bk.Sheets
'check if there is a space in the sheet name
If InStr(sht.Name, " ") > 0 Then
'get text to left of 1st space
ShtDate = Trim(Left(sht.Name, InStr(sht.Name, " ")))
End If
'only process sheet names with dates
If IsDate(ShtDate) Then
'get 1st empty tow insummary sheet
LastRow = SumSht.Range("A" & Rows.Count).End(xlUp).Row
NewRow = LastRow + 1
'get last row from newly opened book
LastRow = sht.Range("A" & Rows.Count).End(xlUp).Row
'copy rows from opened workbbook
'put data into this workbook
'skip row 1
sht.Rows("2:" & LastRow).Copy _
Destination:=SumSht.Rows(NewRow)
End If
Next sht
bk.Close savechanges:=False
FName = Dir()
Loop


End Sub

 

[statum]

This works for me....You will need to create a "click box" to start the macro
(but NOT on the sheet you are importing to. Or you could put this code in the
sub Workbook_Open().

Sub ImportSheet()
Sheets("SHEET1").Activate
Response = MsgBox("Are you sure you want to do this?" & Chr(13) & "This will
delete any current data on this worksheet", vbYesNo)
If Response = vbNo Then Exit Sub
FileName = Application.InputBox(Prompt:="Enter the EXACT File Name of the
workbook you wish" & Chr(13) & "to import from the DATA folder on the C
drive: ", Type:=2)

With ActiveSheet.QueryTables.Add(Connection:=Array( _
"OLEDB;Provider=Microsoft.Jet.OLEDB.4.0;Password="""";User
ID=Admin;Data Source=C:\DATA\" & FileName & ".xls;M" _
, _
"ode=Share Deny Write;Extended Properties=""HDR=YES;"";Jet
OLEDB:System database="""";Jet OLEDB:Registry Path="""";Jet OLEDBatabase P"
_
, _
"assword="""";Jet OLEDB:Engine Type=35;Jet OLEDBatabase Locking
Mode=0;Jet OLEDB:Global Partial Bulk Ops=2;Jet OLEDB:Global Bulk " _
, _
"Transactions=1;Jet OLEDB:New Database Password="""";Jet
OLEDB:Create System Database=False;Jet OLEDB:Encrypt Database=False;Jet OL" _
, _
"EDBon't Copy Locale on Compact=False;Jet OLEDB:Compact Without
Replica Repair=False;Jet OLEDB:SFP=False" _
), Destination:=Range("A1"))
.CommandType = xlCmdTable
.CommandText = Array("WORKLOG$A1:AA10000")
.Name = Filename
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = False
.AdjustColumnWidth = False
.RefreshPeriod = 0
.PreserveColumnInfo = True
.SourceDataFile = "C:\DATA\" & FileName & ".xls"
.Refresh BackgroundQuery:=False
.MaintainConnection = False
End With