Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
Hi Prometheus,
Ron de Bruin has some code examples which may assist you at: http://www.rondebruin.nl/copy3.htm and http://www.rondebruin.nl/ado.htm See also Ron's summary page to access additiional code samples: http://www.rondebruin.nl/tips.htm --- Regards, Norman "Prometheus" wrote in message oups.com... 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 |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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. |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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). --- Regards, Norman "Prometheus" wrote in message oups.com... 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 |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 "Prometheus" wrote: 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 |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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.... |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 "Prometheus" wrote: 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.... |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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. --- Regards, Norman "Prometheus" wrote in message oups.com... 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.... |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 '<<============== --- Regards, Norman |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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. |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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. |
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 '<<============== --- Regards, Norman "Prometheus" wrote in message oups.com... 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. |
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 '<<============== --- Regards, Norman "Norman Jones" wrote in message ... 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 '<<============== --- Regards, Norman "Prometheus" wrote in message oups.com... 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. |
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 |
#16
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
Hi Prometheus,
There is a slight issue . It seems to stop at having reached 38 files through the folder. Any thoughts? 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? --- Regards, Norman "Prometheus" wrote in message ups.com... 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 |
#17
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 |
#18
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
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 |
#19
Posted to microsoft.public.excel.programming
|
|||
|
|||
Copy & Past from multiple sheets to one
Hi Prometheus,
If you comment the line: On Error GoTo CleanUp What error is reported and which line is highlighted? --- Regards, Norman "Prometheus" wrote in message oups.com... 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 |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
copy rows to multiple sheets | Excel Discussion (Misc queries) | |||
Copy data to multiple sheets | Excel Worksheet Functions | |||
Copy and past to different sheets | Excel Discussion (Misc queries) | |||
Multiple sheets selection and copy | Excel Programming | |||
Copy from Multiple Sheets | Excel Programming |