Copy & Past from multiple sheets to one

P

Prometheus

G'day Guys,


I have a few hundred workbooks in a folder (each containing only a
single sheet) which contain information in the cell range F12:G40


What I'm trying to acheive is to consolidate the data onto a single
sheet (in a new workbook)and seperate the data onto individual rows on
the resulting sheet.


For example:
F12 would be copied to A2, F13 to A3, G13 to A4, F14 to A5, G14 to A6,
F15 to A7, G15 to A8.... and so on. With A1 on the new sheet taking the

name of the sheet with the data. Once the data is on a single line,
closing the sheet opening the next sheet in the folder and doing the
same with Row B, next sheet on Row C and so on.


So From this:


Sheet1 Sheet2


Data F12 Data F12
Data F13 Data G13 Data F13 Data G13
Data F14 Data G14 Data F14 Data G14
Data F15 Data G15 Data F15 Data G15
Data F16 Data G16 Data F16 Data G16
Data F17 Data G17 Data F17 Data G17
Data F18 Data G18 Data F18 Data G18


To This:


Resulting Sheet


Sheet1 Data F12 Data F13 Data G13 Data F14 Data G14 Data F15
Data G15 Data F16 Data G16...... etc....
Sheet2 Data F12 Data F13 Data G13 Data F14 Data G14 Data F15
Data G15 Data F16 Data G16...... etc....
Sheet3 Data F12 Data F13 Data G13 Data F14 Data G14 Data F15
Data G15 Data F16 Data G16...... etc....


What I have so far to work with is this....


Sub ACollectall()
On Error GoTo Exit_Line
Application.ScreenUpdating = False
Application.EnableEvents = False


Dim wbkTempBook As Workbook
Dim shtPasteSheet As Worksheet, shtTemp As Worksheet
Dim lngMaxRow As Long, lngCopyRows As Long, lngPasteRow As Long,
lngIgnoreRows As Long


lngPasteRow = 1 'Row to start copying to
lngIgnoreRows = 11 'Number of Rows to ignore


Set shtPasteSheet = ThisWorkbook.Sheets(1)


sFolderPath = "C:\Desktop\Data\"


sTempName = Dir(sFolderPath & "*.*")
Do While sTempName <> ""
Set wbkTempBook = Workbooks.Open(sFolderPath & "\" & sTempName,
True, True)
Set shtTemp = wbkTempBook.Sheets(1)
wbkTempBook.Sheets(1).Range("F12:G40") = wbkTempBook.Sheets(1).Name

lngMaxRow = 110
lngCopyRows = lngMaxRow - lngIgnoreRows
If lngMaxRow > lngIgnoreRows Then
shtTemp.Range("A" & lngIgnoreRows + 1 & ":V" & lngMaxRow).Copy
_
shtPasteSheet.Range("A" & lngPasteRow & ":V" & lngPasteRow
+ lngCopyRows - 1)
lngPasteRow = lngPasteRow + lngCopyRows
End If
wbkTempBook.Close (False)
sTempName = Dir
Loop


What this does is copy the data as a block, move onto the next empty
cell, open the next sheet and repeat the process. Is there a way of
taking the data from the multidude of sheets I have and placing it on a

resulting sheet Row by Row?


Any help would be appreciated!


Cheers
 
P

Prometheus

Thanks for that, looking through it there's stuff I can adapt but I
can't get my head around putting the parts of each macro together to do
what I want it to.
 
P

Prometheus

Norman,

Thanks for the link. The examples shown do basically the same thing as
the macro I've pasted above. What I can't get my head around is putting
the different parts of each macro example there to do what I want from
it.

Cheers
 
N

Norman Jones

Hi Prometheus,

Your described scenario is unclear or ambiguous to me.

If you do not receive satisfactory assistance elsewhere, you may, if you,
wish send me samples of two source books and a sample of the summary book.
If the data is sensitive, by all means use replacement data. However, given
time zones and other commitments, I will probably be unable to deal with
this until tomorrow.

norman_jones@NOSPAMbtconnectDOTcom

Delete'NOSPAM' and replace 'DOT' with a period (full stop).
 
P

PY & Associates

We did not look into your sample code, but maybe you can fit the following in
to suit your purpose please

Set rng = Range("a20").Offset(1, 0) <--- adjust
j = 1
For i = 2 To 7 <--- 13 to 40 for you
j = j + 1
rng.Offset(0, j) = Cells(i, "A") <--- "F" for you
j = j + 1
rng.Offset(0, j) = Cells(i, "B") <--- "G" for you
Next i

We are not sure what "sheet1" is, and why G12 is missing.
We leave them to you as exercise please
 
P

Prometheus

Sorry If my examples seemed strange, it was the best way I knew how to
describe the set-up I'm working with.

Basically each workbook in the folder I'm working with with has several
hundred workbooks which contains the following data in this format on
the first sheet.

SheetName1


Data F12

Data F13 Data G13
Data F14 Data G14
Data F15 Data G15
Data F16 Data G16
Data F17 Data G17
Data F18 Data G18

So each workbook has all the data in the same fields - the data is
obviously different. G12 is not required.

I need to take this data range from each of the seperate workbooks in
the folder and transpose it to a main workbook in the following format.


A B C D E F
1|SheetName1|Data F12|Data F13|Data G13|Data F14|..etc..
2|SheetName2|Data F12|Data F13|Data G13|Data F14|..etc..
3|SheetName3|Data F12|Data F13|Data G13|Data F14|..etc..

So if I began with 400 workbooks in the folder, I would be left with
400 lines in the new workbook.

I hope that made sense... :)

Norman, thanks for the offer, I may send you examples of what I'm
after.

Cheers and thanks all....
 
P

PY & Associates

We believe you have sufficient information to adjust for your need now.

You said each workbook has one sheet,
you did not mention this one sheet has different names
then rng=activesheet.name serves your purpose

Cheers
 
N

Norman Jones

Hi Prometeus,

Try this adaptation of Ron de Bruin's code:

'==============>>
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim sourceRange2 As Range
Dim destrange As Range
Dim destRange2 As Range
Dim rnum As Long
Dim CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\Desktop\Data\"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

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

'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).Range("F12:F18")
Set sourceRange2 = mybook.Worksheets(1).Range("G13:G18")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("A" & rnum)
Set destRange2 = basebook.Worksheets(1).Range("H" & rnum)
' This will add the workbook name in column D if you want
basebook.Worksheets(1).Cells(rnum, "D").Value = mybook.Name

sourceRange.Copy
destrange.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

sourceRange2.Copy
destRange2.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If

CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<==============

I have used the source directory suggested in your post, but this may need
to be changed.

The code worked for my test directory files, but I suggest that you perform
a preparatory test on a limited sample opf workbooks.
 
N

Norman Jones

Hi Prometheus,

I omitted to allow for the workbook names in column A, so please replace the
code with the following version:

'==============>>
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim sourceRange As Range
Dim sourceRange2 As Range
Dim destrange As Range
Dim destRange2 As Range
Dim rnum As Long
Dim CalcMode As Long

'Fill in the path\folder where the files are
MyPath = "C:\One" '"C:\Desktop\Data\"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

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

'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
Set sourceRange = mybook.Worksheets(1).Range("F12:F18")
Set sourceRange2 = mybook.Worksheets(1).Range("G13:G18")
SourceRcount = sourceRange.Rows.Count
Set destrange = basebook.Worksheets(1).Range("B" & rnum)
Set destRange2 = basebook.Worksheets(1).Range("I" & rnum)
' This will add the workbook name in column D if you want
basebook.Worksheets(1).Cells(rnum, "A").Value = mybook.Name

sourceRange.Copy
destrange.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
sourceRange2.Copy
destRange2.PasteSpecial _
Paste:=xlAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True

rnum = rnum + 1
mybook.Close savechanges:=False
Next Fnum
End If

CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<==============
 
P

Prometheus

Norman,

considering I'm no programmer, it's not hard to see in the VB code
actually what you're doing with the scripting. It makes sense.
I'll let you know how it goes, should get play around with this
tonight.

Cheers & Thanks.
 
P

Prometheus

Norman,

The VB Code didn't quite work.

The resulting sheet was close to what was expected. But I think the
error came down to my example above which didn't leave me room to
exactly show what was required in a google groups posting.

The resulting file gave the format:

Sheetname|F12|F13|F14|F15|F16|F17|F18|G13|G14|G15|G16

Is it Possible to output in this format?

Sheetname|F12|F13|G13|F14|G14|F15|G15 and so on t

F13 onwards would ideally allternate with it's corresponding G.

Cheers
Prometheus.
 
N

Norman Jones

Hi Prometheus,

I have tweaked the sequences, so try:

'==============>>
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim SourceRcount As Long
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim rnum As Long
Dim CalcMode As Long
Dim i As Long

'Fill in the path\folder where the files are
MyPath = "C:\Desktop\Data\"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

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

'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

With basebook.Sheets(1)
.Cells(rnum, "A").Value = mybook.Name
.Cells(rnum, "B").Value = _
mybook.Sheets(1).Range("F12").Value

For i = 1 To 6
.Cells(rnum, "A").Resize(1, 2). _
Offset(0, 2 * i).Value = _
mybook.Sheets(1).Range("F12").Offset(i). _
Resize(1,
2).Value
Next i

End With

rnum = rnum + 1

mybook.Close savechanges:=False

Next Fnum

End If

CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<==============
 
N

Norman Jones

Hi Prometheus,

Removing a redundant variable and (attempting) to overcome a slight
line-wrap problem, try instead:

'==============>>
Sub Tester()
Dim MyPath As String
Dim FilesInPath As String
Dim MyFiles() As String
Dim Fnum As Long
Dim mybook As Workbook
Dim basebook As Workbook
Dim rnum As Long
Dim CalcMode As Long
Dim i As Long

'Fill in the path\folder where the files are
MyPath = "C:\One" '"C:\Desktop\Data\"

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & "*.xls")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

On Error GoTo CleanUp

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

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

'Fill the array(myFiles)with the list of _
'Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))

With basebook.Sheets(1)
.Cells(rnum, "A").Value = mybook.Name
.Cells(rnum, "B").Value = _
mybook.Sheets(1).Range("F12").Value

For i = 1 To 6
.Cells(rnum, "A").Resize(1, 2). _
Offset(0, 2 * i).Value = _
mybook.Sheets(1).Range("F12").Offset(i). _
Resize(1, 2).Value
Next i
End With

rnum = rnum + 1

mybook.Close savechanges:=False
Next Fnum
End If

CleanUp:
With Application
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub
'<<==============
 
P

Prometheus

Norman,

thank-you. Exactly what I was after.

There is a slight issue . It seems to stop at having reached 38 files
through the folder.
Any thoughts?

Cheers & thanks again.
Prometheus
 
N

Norman Jones

Hi Prometheus,
There is a slight issue . It seems to stop at having reached 38 files
through the folder.
Any thoughts?
Click to expand...

Do you mean that the code completes but only reports 38 files or is the
macro stopping with an error?

If the latter, what error is reported and which line is highlighted?
 
P

Prometheus

The code completes and reports on 38 files.

The 39th is open but the macro doesn't do anything with it. Funny thing
is taking that file out of the directory allows the macro to get to 103
files, but then the same thing occurs: Taking the 103rd file out of the
directory allows the macro to report on over 150 files and then the
same thing happens with yet another file.

There must be something different about those particular files which is
breaking the macro and sending it to "Cleanup".

I have figured that it's not your macro. Which works wonderfully. Can't
thank you enough.

Cheers
Prometheus
 
P

Prometheus

Norman,

all fixed. Error with the excel page it was opening.
Your help on this was greatfully appreciated! Can't thank you enough.

What used to take me days each week to do will now take me a morning
(if that).

Thanks again.
Promrtheus
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel Macro to Copy & Paste 0
Macro Help- combining "CS" files 1
Sub to clear range above n below diagonal 8
Pls Help - blank cell/formula issue 7
Userform help please 5
Copy Data from One sheet to Different Sheets 1
Repeat formula in new rows 4
Creating a variable and pickout data 1

Top