Copy the same column from 50 sheets into a new sheet macro help!

  • Thread starter Thread starter spidle
  • Start date Start date
S

spidle

Hey folks,

I have a macro that works great in running a macro on all files in a
folder, but now I need a macro to copy the same column (column I) from
each of the 50 sheets in the folder and paste all of them into a new
worksheet starting at column A and continuing down the line.

Help!
 
Rather than rewriting code that works, why not paste your code in and someone
can show you how to modify it.
 
Sorry about that!

Here is what I have so far (gleaned from pouring through newsgroups):
Sub Compile()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Documents and Settings\rspidle\Desktop\CNA Survey"
ChDrive MyPath
ChDir MyPath


FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
'clear all cells on the first sheet
rnum = 1

Do While FNames <> ""
If LCase(Left(FNames, 4)) <> "survey" Then
Set mybook = Workbooks.Open(FNames)
Set sourceRange = mybook.Worksheets(1).Range("I1:I140")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Cells(rnum, 1)

' basebook.Worksheets(1).Cells(rnum, "D").Value =
mybook.Name
' This will add the workbook name in column D if you want

sourceRange.Copy destrange
'Instead of this line you can use the code below to copy
only the values


' With sourceRange
' Set destrange = basebook.Worksheets(1).Cells(rnum,
"A"). _
' Resize(.Rows.Count,
..Columns.Count)
' End With
' destrange.Value = sourceRange.Value

rnum = rnum + SourceRcount
mybook.Close False
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub


What I get with this is all of the data copied over... but all of it
copied into Column A and I need it copied into subsequent columns
(think N+1).

Rob
 
You can use this :
Sub Valuefromfileinfolder()
dim r as long
For r = 1 To 50 '50 means numbers of file in a folder c:\
with range("A" & r)
.FormulaArray = "='C:\[Book" & r &
".xls]Sheet1'!I1 'book in folder c:\ must be named "Book1.xls" up to
"Book50.xls"
.Value=.value
end with
next r
end sub


Try it,

Halim
 
You can use this :
Sub Valuefromfileinfolder()
dim r as long
For r = 1 To 50 '50 means numbers of file in a folder c:\
with range("A" & r)
.FormulaArray = "='C:\[Book" & r &
".xls]Sheet1'!I1 'book in folder c:\ must be named "Book1.xls" up to
"Book50.xls"
.Value=.value
end with
next r
end sub
Click to expand...
I tried that and it gave me all kinds of object and compile errors.
I assumed that the formatting got a little wonky in the c&p so I
tinkered around with it a bit, but it still seems to be fighting back.
;)

r
 
Sub Compile()
Dim basebook As Workbook
Dim mybook As Workbook
Dim sourceRange As Range
Dim destrange As Range
Dim rnum As Long
Dim SourceRcount As Long
Dim FNames As String
Dim MyPath As String
Dim SaveDriveDir As String

SaveDriveDir = CurDir
MyPath = "C:\Documents and Settings\rspidle\Desktop\CNA Survey"
ChDrive MyPath
ChDir MyPath


FNames = Dir("*.xls")
If Len(FNames) = 0 Then
MsgBox "No files in the Directory"
ChDrive SaveDriveDir
ChDir SaveDriveDir
Exit Sub
End If

Application.ScreenUpdating = False
Set basebook = ThisWorkbook
basebook.Worksheets(1).Cells.Clear
'clear all cells on the first sheet
rnum = 0

Do While FNames <> ""
If LCase(Left(FNames, 4)) <> "survey" Then
Set mybook = Workbooks.Open(FNames)
rnum = rnum + 1
Set sourceRange = mybook.Worksheets(1).Range("I1:I140")
Set destrange = basebook.Worksheets(1).Cells(2, rNum)
basebook.Worksheets(1).Cells(1, rnum).Value = mybook.Name
sourceRange.Copy destrange
mybook.Close False
End If
FNames = Dir()
Loop
ChDrive SaveDriveDir
ChDir SaveDriveDir
Application.ScreenUpdating = True
End Sub
 
I tried that and it gave me all kinds of object and compile errors.
I assumed that the formatting got a little wonky in the c&p so I
tinkered around with it a bit, but it still seems to be fighting back.
;)

r
Click to expand...

Hi,

You must naming workbook same like in formulaArray book1 ~ book50 too
with the same name of sheet1 in each workbook

Thanks,

Halim
 
Rock on! Thanks, Tom - that worked like a champ!
Now... the fun and joy of creating pivot tables with all of this
data...
 
Back
Top