Combine multiple books into one list

[Steve Mackay]

Hi All

I am very novice at VBA. I only know how to record macros and then
modify them to do what I need. Using Excel 2002.

I am trying to combine data from multiple (about 100) workbooks into
one vertical list in a different workbook. Each workbook has a sheet
named "IO" with four values I want to copy (cells B2:E2) plus the name
of the workbook in cell A1. The resulting list would look like this:

A B C D E
1 WorkbookName1 Value1 Value2 Value3 Value4

2 WorkbookName2 Value1 Value2 Value3 Value4

3 etc...

I've copied someone's macro that will cycle through the workbooks in a
directory and copy the cells I need. The only thing that I can't do
is figure out how to paste it in the next empty row. I am sure this
is an easy question, just not sure of the code. Here is what I have
so far:

Sub RegionList()

Dim FileList() As String
Dim Counter As Long
Dim NextFile As String
Dim thisfile As String
Dim DirToSearch As String

DirToSearch = "C:\Documents and Settings\User1\My Documents\CBAs\"
Counter = 0

NextFile = Dir(DirToSearch & "\" & "*.xls")

Do Until NextFile = ""
ReDim Preserve FileList(Counter)
FileList(Counter) = DirToSearch & "\" & NextFile
Counter = Counter + 1
NextFile = Dir()
Loop
Application.Calculation = xlManual
On Error Resume Next
For Counter = LBound(FileList) To UBound(FileList)
'MsgBox FileList(Counter)
Workbooks.Open Filename:=FileList(Counter)
ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count).Name = thisfile
Windows(thisfile).Activate
Sheets("IO").Select
Range("A1").Select
Selection.Copy

Windows("NewBook.xls").Activate 'this is open to the correct sheet
Range("A1").Select
'this is where I need it to select the next blank row in column A and
paste

Windows(thisfile).Activate
Sheets("IO").Select
Range("B2:E2").Select
Selection.Copy

Windows("NewBook.xls").Activate
Range("B1").Select
'this is where I need it to select the cell in column B next to the
workbook name that I just pasted

Windows(thisfile).Activate
ActiveWorkbook.Save
Workbooks(thisfile).Close
Next
Application.Calculation = xlAutomatic

End Sub

 

[Greg Koppel]

Use the following

Range("A65536").End(xlUp).Offset(1, 0).Select

 

[Dave Peterson]

I was kind of confused, but maybe this'll give you some ideas. It uses a nice
function from Chip Pearson to check to see if a worksheet exists.



Option Explicit
Sub RegionList2()

Dim FileList() As String
Dim Counter As Long
Dim NextFile As String

Dim DirToSearch As String
Dim nextWkbk As Workbook
Dim ToWks As Worksheet
Dim oRow As Long
'DirToSearch = "C:\Documents and Settings\User1\My Documents\CBAs\"
DirToSearch = "C:\my documents\excel\test\"
Counter = 0

NextFile = Dir(DirToSearch & "\" & "*.xls")
Do Until NextFile = ""
ReDim Preserve FileList(Counter)
FileList(Counter) = DirToSearch & "\" & NextFile
Counter = Counter + 1
NextFile = Dir()
Loop

If Counter = 0 Then
'no files found
Exit Sub
End If

'I wasn't sure where you were putting the results
'so I made a new sheet
Set ToWks = ThisWorkbook.Worksheets.Add
ToWks.Range("a1").Resize(1, 5).Value _
= Array("name", "B2", "C2", "D2", "E2")

oRow = 1
Application.Calculation = xlManual
'maybe you won't need the on error statement??
'On Error Resume Next
For Counter = LBound(FileList) To UBound(FileList)
'MsgBox FileList(Counter)
Set nextWkbk = Workbooks.Open(Filename:=FileList(Counter))

If WorksheetExists("IO", nextWkbk) Then
oRow = oRow + 1
ToWks.Cells(oRow, "A").Value _
= nextWkbk.Worksheets("IO").Range("A1").Value
ToWks.Cells(oRow, "B").Resize(1, 4).Value _
= nextWkbk.Worksheets("Io").Range("b2:e2").Value
End If

nextWkbk.Close savechanges:=False
Next Counter

'thisworkbook.save
Application.Calculation = xlAutomatic

End Sub

Function WorksheetExists(SheetName As String, _
Optional WhichBook As Workbook) As Boolean
'from Chip Pearson
Dim WB As Workbook
Set WB = IIf(WhichBook Is Nothing, ThisWorkbook, WhichBook)
On Error Resume Next
WorksheetExists = CBool(Len(WB.Worksheets(SheetName).Name) > 0)
End Function

 

[Steve Mackay]

Thanks, Greg. That's exactly what I was looking for.

Steve Mackay

 

[Steve Mackay]

Thanks for the help, Dave. Sorry for the confusion...I think I had left a
line out and had another one that I didn't need. Here is the final code and
it works great.

Sub RegionList()
Dim FileList() As String
Dim Counter As Long
Dim NextFile As String
Dim thisfile As String
Dim DirToSearch As String
DirToSearch = "C:\Documents and Settings\User1\My Documents\CBAs"
Counter = 0
NextFile = Dir(DirToSearch & "\" & "*.xls")
Do Until NextFile = ""
ReDim Preserve FileList(Counter)
FileList(Counter) = DirToSearch & "\" & NextFile
Counter = Counter + 1
NextFile = Dir()
Loop
Application.Calculation = xlManual
On Error Resume Next
For Counter = LBound(FileList) To UBound(FileList)
Workbooks.Open Filename:=FileList(Counter)
thisfile = ActiveWorkbook.Name
'Paste Name
Windows(thisfile).Activate
Sheets("IO").Select
Range("A1").Select
Selection.Copy
Windows("NewBook.xls").Activate
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False

'Paste Investment Values
Windows(thisfile).Activate
Sheets("CBA Template").Select
Range("B2:E2").Select
Selection.Copy
Windows("NewBook.xls").Activate
Range("B65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Workbooks(thisfile).Saved = True
Workbooks(thisfile).Close
Next
Application.Calculation = xlAutomatic
End Sub

Steve Mackay