I need to copy cells from 4 w'sheets in multiple w'books to 1 w'sheet in 1 w'book

P

plant007

Board Regular
Joined
Jun 2, 2011
Messages
55
Office Version
  1. 2019
Platform
  1. Windows
Hello<?xml:namespace prefix = o ns = "urn:schemas-microsoft-com:office:office" /><o:p></o:p>
<o:p></o:p>
As somebody with no coding experience, I have a question re the coding below if that is ok;<o:p></o:p>
<o:p></o:p>
Next month, I am being sent 200 project workbooks, each consisting of 4 worksheets where the data in the first worksheet in each workbook is standardised (as is all worksheets 2s, 3s and 4s in each workbook) but there is no standardisation between worksheet 1, 2, 3 and 4 within each workbook. The workbooks being sent to me for Quarter 1 reporting and will be put in a folder labelled 2011Q1R. <o:p></o:p>
I need to consolidate the workbooks by;<o:p></o:p>
<o:p></o:p>
1) Creating a consolidated standardised master workbook which consists of one worksheet with an embedded macro (button) which pulls all the data from each worksheet within each project workbook (not the workbook itself) and arranges it into a one-row entry so that I am left with a standardised workbook with single row entries for each of the project workbooks in the Q1 folder<o:p></o:p>
2) I will receive approx 200 workbooks every three months, placed in 2011 Q2R etc which will need to be added to the master workbook which I assume can be done using the macros in 1 with a little tweaking i.e. source<o:p></o:p>
<o:p></o:p>
Efforts so far have amounted to having a consolidation worksheet with two macro buttons, the first of which draws in all the worksheets from the workbooks (not the data) in the folder to the consolidation workbook while the second macro button uses 4 versions of the inital coding below (1 for each worksheet) along with recorded a macro that ensures all data from one workbook is on one row (the initial coding below puts each worksheet data on subsequent rows), run by way of an overarching subroutine. As I am sure you can tell, apart from dragging the workbooks and not the data, the macros also only consolidate 1 workbook. Would there be some way of tweaking the coding below so that I can achieve (1) above or would it need a completely new macro?<o:p></o:p>
<o:p></o:p>
I hope this makes sense but any questions, please ask. I have als postd this on http://www.pcreview.co.uk/forums/co...s-1-wsheet-1-wbook-t4037086.html#post14093003<o:p></o:p>
<o:p></o:p>
Thanks in advance for any help you may be able to provide<o:p></o:p>
Thanks<o:p></o:p>
Andrew<o:p></o:p>
<o:p></o:p>

Code: 
Public Sub CopyCells2()<o:p></o:p>
Dim TargetRow As Long<o:p></o:p>
Dim TargetCol As Integer<o:p></o:p>
<o:p></o:p>
<o:p></o:p>
'CONFIG HERE<o:p></o:p>
Const TargetSheets As String = "consolidation"<o:p></o:p>
Const SourceCells As String = "C4,c6"<o:p></o:p>
Const SourceSheet As String = "delivery confidence"<o:p></o:p>
<o:p></o:p>
For Each TargSh In Split(TargetSheets, ",")<o:p></o:p>
With ThisWorkbook.Sheets(TargSh)<o:p></o:p>
TargetRow = .Cells(.Rows.Count, 1).End(xlUp).Row + 1<o:p></o:p>
TargetCol = 0<o:p></o:p>
For Each celladdr In Split(SourceCells, ",")<o:p></o:p>
TargetCol = TargetCol + 1<o:p></o:p>
.Cells(TargetRow, TargetCol).Value = _<o:p></o:p>
ThisWorkbook.Sheets(SourceSheet).Range(celladdr).Value<o:p></o:p>
Next celladdr<o:p></o:p>
End With<o:p></o:p>
Next TargSh<o:p></o:p>
End Sub<o:p></o:p>
<o:p></o:p>
Sub GetSheets()<o:p></o:p>
Path = "H:\Bod\GMPP\Pilot data\pilot\"<o:p></o:p>
Filename = Dir(Path & "*.xls")<o:p></o:p>
<o:p></o:p>
Do While Filename <> ""<o:p></o:p>
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True<o:p></o:p>
For Each Sheet In ActiveWorkbook.Sheets<o:p></o:p>
Sheet.Copy After:=ThisWorkbook.Sheets(1)<o:p></o:p>
Next Sheet<o:p></o:p>
Workbooks(Filename).Close<o:p></o:p>
Filename = Dir()<o:p></o:p>
Loop<o:p></o:p>
End Sub<o:p></o:p>
<o:p></o:p>
Sub RunMacrosRun()<o:p></o:p>
<o:p></o:p>
With Application<o:p></o:p>
.ScreenUpdating = False<o:p></o:p>
.EnableEvents = False<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
Dim strDate As String<o:p></o:p>
Dim cmt As Comment<o:p></o:p>
<o:p></o:p>
strDate = "dd-mmm-yy hh:mm:ss"<o:p></o:p>
Set cmt = ActiveCell.Comment<o:p></o:p>
<o:p></o:p>
If cmt Is Nothing Then<o:p></o:p>
Set cmt = ActiveCell.AddComment<o:p></o:p>
cmt.Text Text:="Data Merged on" & Chr(10) & Format(Now, strDate) & Chr(10)<o:p></o:p>
Else<o:p></o:p>
cmt.Text Text:=cmt.Text & Chr(10) & Format(Now, strDate) & Chr(10)<o:p></o:p>
End If<o:p></o:p>
<o:p></o:p>
With cmt.Shape.TextFrame<o:p></o:p>
.Characters.Font.Bold = False<o:p></o:p>
End With<o:p></o:p>
<o:p></o:p>
Application.Run "CopyCells"<o:p></o:p>
Application.Run "Copycells2"<o:p></o:p>
Application.Run "Copycells3"<o:p></o:p>
Application.Run "Copycells4"<o:p></o:p>
Application.Run "MacroAP2"<o:p></o:p>
Application.Run "EE4A"<o:p></o:p>
End Sub
 

Excel Facts

Excel Joke
Why can't spreadsheets drive cars? They crash too often!
Sort by date Sort by votes
Hi Blossomthe2nd

No replies yet but I found another bit of code and have been tinkering with it. Its still not working (I get an error message on the first line) but I feel it is getting slightly closer

Hope it helps
Thanks
Andy

Code: 
Sub TransferData()
    Dim wkb As Workbook, wks As Worksheet, LastRow As Long
    Dim FilePath As String, FileName As String
    Dim ws As Worksheet, blnOpened As Boolean
    'Change these variables as desired...
        FilePath = "H:\Bod\GMPP\Pilot data\pilot\"
        FileName = Dir(Path & "*.xls")
           Call ToggleEvents(False)
    Set ws = ThisWorkbook.Sheets("administrative data", "delivery confidence", "financial data", "milestones") 'change source sheet name here
    If WbOpen(FileName) = True Then
        Set wkb = Workbooks(FileName)
        blnOpened = False
    Else
        If Right(FilePath, 1) <> Application.PathSeparator Then
            FilePath = FilePath & Application.PathSeparator
        End If
        Set wkb = Workbooks.Open(FilePath & FileName)
        blnOpened = True
    End If
    Set wks = wkb.Sheets("consolidation") 'change destination sheet name here
    LastRow = wks.Cells.Find(what:="*", After:=wks.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    wks.Cells(LastRow, "A").Value = ws.Cells(4, "C").Value
    wks.Cells(LastRow, "B").Value = ws.Cells(5, "C").Value
    wks.Cells(LastRow, "C").Value = ws.Cells(6, "C").Value
    wks.Cells(LastRow, "D").Value = ws.Cells(7, "C").Value
    wks.Cells(LastRow, "E").Value = ws.Cells(10, "C").Value
    wks.Cells(LastRow, "F").Value = ws.Cells(11, "C").Value
    wks.Cells(LastRow, "G").Value = ws.Cells(12, "C").Value
    wks.Cells(LastRow, "H").Value = ws.Cells(15, "C").Value
    wks.Cells(LastRow, "I").Value = ws.Cells(16, "C").Value
    wks.Cells(LastRow, "J").Value = ws.Cells(17, "C").Value
    wks.Cells(LastRow, "K").Value = ws.Cells(20, "C").Value
    wks.Cells(LastRow, "L").Value = ws.Cells(21, "C").Value
    wks.Cells(LastRow, "M").Value = ws.Cells(22, "C").Value
    wks.Cells(LastRow, "N").Value = ws.Cells(24, "C").Value
    wks.Cells(LastRow, "O").Value = ws.Cells(26, "C").Value
    wks.Cells(LastRow, "P").Value = ws.Cells(27, "C").Value
    wks.Cells(LastRow, "Q").Value = ws.Cells(28, "C").Value
    wks.Cells(LastRow, "R").Value = ws.Cells(29, "C").Value
 
    Set wks = wkb.Sheets("consolidation") 'change destination sheet name here
    LastRow = wks.Cells.Find(what:="*", After:=wks.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    wks.Cells(LastRow, "S").Value = ws.Cells(4, "C").Value
    wks.Cells(LastRow, "T").Value = ws.Cells(6, "C").Value
 
    Set wks = wkb.Sheets("consolidation") 'change destination sheet name here
    LastRow = wks.Cells.Find(what:="*", After:=wks.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    wks.Cells(LastRow, "U").Value = ws.Cells(6, "B").Value
    wks.Cells(LastRow, "V").Value = ws.Cells(6, "C").Value
    wks.Cells(LastRow, "W").Value = ws.Cells(6, "D").Value
    wks.Cells(LastRow, "X").Value = ws.Cells(6, "E").Value
    wks.Cells(LastRow, "Y").Value = ws.Cells(7, "B").Value
    wks.Cells(LastRow, "Z").Value = ws.Cells(7, "C").Value
    wks.Cells(LastRow, "AA").Value = ws.Cells(7, "D").Value
    wks.Cells(LastRow, "AB").Value = ws.Cells(7, "E").Value
    wks.Cells(LastRow, "AC").Value = ws.Cells(8, "B").Value
    wks.Cells(LastRow, "AD").Value = ws.Cells(8, "C").Value
    wks.Cells(LastRow, "AE").Value = ws.Cells(8, "D").Value
    wks.Cells(LastRow, "AF").Value = ws.Cells(8, "E").Value
    wks.Cells(LastRow, "AG").Value = ws.Cells(6, "F").Value
    wks.Cells(LastRow, "AH").Value = ws.Cells(6, "G").Value
    wks.Cells(LastRow, "AI").Value = ws.Cells(6, "H").Value
    wks.Cells(LastRow, "AJ").Value = ws.Cells(6, "I").Value
    wks.Cells(LastRow, "AK").Value = ws.Cells(7, "F").Value
    wks.Cells(LastRow, "AL").Value = ws.Cells(7, "G").Value
    wks.Cells(LastRow, "AM").Value = ws.Cells(7, "H").Value
    wks.Cells(LastRow, "AN").Value = ws.Cells(7, "I").Value
    wks.Cells(LastRow, "AO").Value = ws.Cells(8, "F").Value
    wks.Cells(LastRow, "AP").Value = ws.Cells(8, "G").Value
    wks.Cells(LastRow, "AQ").Value = ws.Cells(8, "H").Value
    wks.Cells(LastRow, "AR").Value = ws.Cells(8, "I").Value
    wks.Cells(LastRow, "AS").Value = ws.Cells(6, "J").Value
    wks.Cells(LastRow, "AT").Value = ws.Cells(6, "K").Value
    wks.Cells(LastRow, "AU").Value = ws.Cells(6, "L").Value
    wks.Cells(LastRow, "AV").Value = ws.Cells(6, "M").Value
    wks.Cells(LastRow, "AW").Value = ws.Cells(7, "J").Value
    wks.Cells(LastRow, "AX").Value = ws.Cells(7, "K").Value
    wks.Cells(LastRow, "AY").Value = ws.Cells(7, "L").Value
    wks.Cells(LastRow, "AZ").Value = ws.Cells(7, "M").Value
    wks.Cells(LastRow, "BA").Value = ws.Cells(8, "J").Value
    wks.Cells(LastRow, "BB").Value = ws.Cells(8, "K").Value
    wks.Cells(LastRow, "BC").Value = ws.Cells(8, "L").Value
    wks.Cells(LastRow, "BD").Value = ws.Cells(8, "M").Value
    wks.Cells(LastRow, "BE").Value = ws.Cells(6, "N").Value
    wks.Cells(LastRow, "BF").Value = ws.Cells(6, "O").Value
    wks.Cells(LastRow, "BG").Value = ws.Cells(6, "P").Value
    wks.Cells(LastRow, "BH").Value = ws.Cells(6, "Q").Value
    wks.Cells(LastRow, "BI").Value = ws.Cells(7, "N").Value
    wks.Cells(LastRow, "BJ").Value = ws.Cells(7, "O").Value
    wks.Cells(LastRow, "BK").Value = ws.Cells(7, "P").Value
    wks.Cells(LastRow, "BL").Value = ws.Cells(7, "Q").Value
    wks.Cells(LastRow, "BM").Value = ws.Cells(8, "N").Value
    wks.Cells(LastRow, "BN").Value = ws.Cells(8, "O").Value
    wks.Cells(LastRow, "BO").Value = ws.Cells(8, "P").Value
    wks.Cells(LastRow, "BP").Value = ws.Cells(8, "Q").Value
    wks.Cells(LastRow, "BQ").Value = ws.Cells(6, "R").Value
    wks.Cells(LastRow, "BR").Value = ws.Cells(6, "S").Value
    wks.Cells(LastRow, "BS").Value = ws.Cells(6, "T").Value
    wks.Cells(LastRow, "BT").Value = ws.Cells(6, "U").Value
    wks.Cells(LastRow, "BU").Value = ws.Cells(7, "R").Value
    wks.Cells(LastRow, "BV").Value = ws.Cells(7, "S").Value
    wks.Cells(LastRow, "BW").Value = ws.Cells(7, "T").Value
    wks.Cells(LastRow, "BX").Value = ws.Cells(7, "U").Value
    wks.Cells(LastRow, "BY").Value = ws.Cells(8, "R").Value
    wks.Cells(LastRow, "BZ").Value = ws.Cells(8, "S").Value
    wks.Cells(LastRow, "CA").Value = ws.Cells(8, "T").Value
    wks.Cells(LastRow, "CB").Value = ws.Cells(8, "U").Value
    wks.Cells(LastRow, "CC").Value = ws.Cells(6, "V").Value
    wks.Cells(LastRow, "CD").Value = ws.Cells(6, "W").Value
    wks.Cells(LastRow, "CE").Value = ws.Cells(6, "X").Value
    wks.Cells(LastRow, "CF").Value = ws.Cells(6, "Y").Value
    wks.Cells(LastRow, "CG").Value = ws.Cells(7, "V").Value
    wks.Cells(LastRow, "CH").Value = ws.Cells(7, "W").Value
    wks.Cells(LastRow, "CI").Value = ws.Cells(7, "X").Value
    wks.Cells(LastRow, "CJ").Value = ws.Cells(7, "Y").Value
    wks.Cells(LastRow, "CK").Value = ws.Cells(8, "V").Value
    wks.Cells(LastRow, "CL").Value = ws.Cells(8, "W").Value
    wks.Cells(LastRow, "CM").Value = ws.Cells(8, "X").Value
    wks.Cells(LastRow, "CN").Value = ws.Cells(8, "Y").Value
    wks.Cells(LastRow, "CO").Value = ws.Cells(6, "Z").Value
    wks.Cells(LastRow, "CP").Value = ws.Cells(6, "AA").Value
    wks.Cells(LastRow, "CQ").Value = ws.Cells(6, "AB").Value
    wks.Cells(LastRow, "CR").Value = ws.Cells(6, "AC").Value
    wks.Cells(LastRow, "CS").Value = ws.Cells(7, "Z").Value
    wks.Cells(LastRow, "CT").Value = ws.Cells(7, "AA").Value
    wks.Cells(LastRow, "CU").Value = ws.Cells(7, "AB").Value
    wks.Cells(LastRow, "CV").Value = ws.Cells(7, "AC").Value
    wks.Cells(LastRow, "CW").Value = ws.Cells(8, "Z").Value
    wks.Cells(LastRow, "CX").Value = ws.Cells(8, "AA").Value
    wks.Cells(LastRow, "CY").Value = ws.Cells(8, "AB").Value
    wks.Cells(LastRow, "CZ").Value = ws.Cells(8, "AC").Value
    wks.Cells(LastRow, "DA").Value = ws.Cells(6, "AD").Value
    wks.Cells(LastRow, "DB").Value = ws.Cells(6, "AE").Value
    wks.Cells(LastRow, "DC").Value = ws.Cells(7, "AD").Value
    wks.Cells(LastRow, "DD").Value = ws.Cells(7, "AE").Value
    wks.Cells(LastRow, "DE").Value = ws.Cells(8, "AD").Value
    wks.Cells(LastRow, "DF").Value = ws.Cells(8, "AE").Value
    wks.Cells(LastRow, "DG").Value = ws.Cells(12, "B").Value
    wks.Cells(LastRow, "DH").Value = ws.Cells(12, "C").Value
    wks.Cells(LastRow, "DI").Value = ws.Cells(12, "D").Value
    wks.Cells(LastRow, "DJ").Value = ws.Cells(12, "E").Value
    wks.Cells(LastRow, "DK").Value = ws.Cells(12, "F").Value
    wks.Cells(LastRow, "DL").Value = ws.Cells(12, "G").Value
    wks.Cells(LastRow, "DM").Value = ws.Cells(12, "H").Value
    wks.Cells(LastRow, "DN").Value = ws.Cells(12, "I").Value
    wks.Cells(LastRow, "DO").Value = ws.Cells(12, "J").Value
    wks.Cells(LastRow, "DP").Value = ws.Cells(12, "K").Value
    wks.Cells(LastRow, "DQ").Value = ws.Cells(12, "L").Value
    wks.Cells(LastRow, "DR").Value = ws.Cells(12, "M").Value
    wks.Cells(LastRow, "DS").Value = ws.Cells(12, "N").Value
    wks.Cells(LastRow, "DT").Value = ws.Cells(12, "O").Value
    wks.Cells(LastRow, "DU").Value = ws.Cells(12, "P").Value
    wks.Cells(LastRow, "DV").Value = ws.Cells(12, "Q").Value
    wks.Cells(LastRow, "DW").Value = ws.Cells(12, "R").Value
    wks.Cells(LastRow, "DX").Value = ws.Cells(12, "S").Value
    wks.Cells(LastRow, "DY").Value = ws.Cells(12, "T").Value
    wks.Cells(LastRow, "DZ").Value = ws.Cells(12, "U").Value
    wks.Cells(LastRow, "EA").Value = ws.Cells(12, "V").Value
    wks.Cells(LastRow, "EB").Value = ws.Cells(12, "W").Value
    wks.Cells(LastRow, "EC").Value = ws.Cells(12, "X").Value
    wks.Cells(LastRow, "ED").Value = ws.Cells(12, "Y").Value
    wks.Cells(LastRow, "EE").Value = ws.Cells(12, "Z").Value
    wks.Cells(LastRow, "EF").Value = ws.Cells(12, "AA").Value
    wks.Cells(LastRow, "EG").Value = ws.Cells(12, "AB").Value
    wks.Cells(LastRow, "EH").Value = ws.Cells(12, "AC").Value
    wks.Cells(LastRow, "EI").Value = ws.Cells(12, "AD").Value
    wks.Cells(LastRow, "EJ").Value = ws.Cells(15, "F").Value
 
 
    Set wks = wkb.Sheets("consolidation") 'change destination sheet name here
    LastRow = wks.Cells.Find(what:="*", After:=wks.Cells(1, 1), searchorder:=xlByRows, searchdirection:=xlPrevious).Row + 1
    wks.Cells(LastRow, "EK").Value = ws.Cells(5, "B").Value
    wks.Cells(LastRow, "EL").Value = ws.Cells(5, "C").Value
    wks.Cells(LastRow, "EM").Value = ws.Cells(5, "D").Value
    wks.Cells(LastRow, "EN").Value = ws.Cells(5, "E").Value
    wks.Cells(LastRow, "EO").Value = ws.Cells(5, "F").Value
    wks.Cells(LastRow, "EP").Value = ws.Cells(6, "B").Value
    wks.Cells(LastRow, "EQ").Value = ws.Cells(6, "C").Value
    wks.Cells(LastRow, "ER").Value = ws.Cells(6, "D").Value
    wks.Cells(LastRow, "ES").Value = ws.Cells(6, "E").Value
    wks.Cells(LastRow, "ET").Value = ws.Cells(6, "F").Value
    wks.Cells(LastRow, "EU").Value = ws.Cells(7, "B").Value
    wks.Cells(LastRow, "EV").Value = ws.Cells(7, "C").Value
    wks.Cells(LastRow, "EW").Value = ws.Cells(7, "D").Value
    wks.Cells(LastRow, "EX").Value = ws.Cells(7, "E").Value
    wks.Cells(LastRow, "EY").Value = ws.Cells(7, "F").Value
    wks.Cells(LastRow, "EZ").Value = ws.Cells(8, "B").Value
    wks.Cells(LastRow, "FA").Value = ws.Cells(8, "C").Value
    wks.Cells(LastRow, "FB").Value = ws.Cells(8, "D").Value
    wks.Cells(LastRow, "FC").Value = ws.Cells(8, "E").Value
    wks.Cells(LastRow, "FD").Value = ws.Cells(8, "F").Value
    wks.Cells(LastRow, "FE").Value = ws.Cells(9, "B").Value
    wks.Cells(LastRow, "FF").Value = ws.Cells(9, "C").Value
    wks.Cells(LastRow, "FG").Value = ws.Cells(9, "D").Value
    wks.Cells(LastRow, "FH").Value = ws.Cells(9, "E").Value
    wks.Cells(LastRow, "FI").Value = ws.Cells(9, "F").Value
    wks.Cells(LastRow, "FJ").Value = ws.Cells(10, "B").Value
    wks.Cells(LastRow, "FK").Value = ws.Cells(10, "C").Value
    wks.Cells(LastRow, "FL").Value = ws.Cells(10, "D").Value
    wks.Cells(LastRow, "FM").Value = ws.Cells(10, "E").Value
    wks.Cells(LastRow, "FN").Value = ws.Cells(10, "F").Value
    wks.Cells(LastRow, "FO").Value = ws.Cells(11, "B").Value
    wks.Cells(LastRow, "FP").Value = ws.Cells(11, "C").Value
    wks.Cells(LastRow, "FQ").Value = ws.Cells(11, "D").Value
    wks.Cells(LastRow, "FR").Value = ws.Cells(11, "E").Value
    wks.Cells(LastRow, "FS").Value = ws.Cells(11, "F").Value
    wks.Cells(LastRow, "FT").Value = ws.Cells(12, "B").Value
    wks.Cells(LastRow, "FU").Value = ws.Cells(12, "C").Value
    wks.Cells(LastRow, "FV").Value = ws.Cells(12, "D").Value
    wks.Cells(LastRow, "FW").Value = ws.Cells(12, "E").Value
    wks.Cells(LastRow, "FX").Value = ws.Cells(12, "F").Value
    wks.Cells(LastRow, "FY").Value = ws.Cells(13, "B").Value
    wks.Cells(LastRow, "FZ").Value = ws.Cells(13, "C").Value
    wks.Cells(LastRow, "GA").Value = ws.Cells(13, "D").Value
    wks.Cells(LastRow, "GB").Value = ws.Cells(13, "E").Value
    wks.Cells(LastRow, "GC").Value = ws.Cells(13, "F").Value
    wks.Cells(LastRow, "GD").Value = ws.Cells(14, "B").Value
    wks.Cells(LastRow, "GE").Value = ws.Cells(14, "C").Value
    wks.Cells(LastRow, "GF").Value = ws.Cells(14, "D").Value
    wks.Cells(LastRow, "GG").Value = ws.Cells(14, "E").Value
    wks.Cells(LastRow, "GH").Value = ws.Cells(14, "F").Value
    wks.Cells(LastRow, "GI").Value = ws.Cells(15, "B").Value
    wks.Cells(LastRow, "GJ").Value = ws.Cells(15, "C").Value
    wks.Cells(LastRow, "GK").Value = ws.Cells(15, "D").Value
    wks.Cells(LastRow, "GL").Value = ws.Cells(15, "E").Value
    wks.Cells(LastRow, "GM").Value = ws.Cells(15, "F").Value
    wks.Cells(LastRow, "GN").Value = ws.Cells(16, "B").Value
    wks.Cells(LastRow, "GO").Value = ws.Cells(16, "C").Value
    wks.Cells(LastRow, "GP").Value = ws.Cells(16, "D").Value
    wks.Cells(LastRow, "GQ").Value = ws.Cells(16, "E").Value
    wks.Cells(LastRow, "GR").Value = ws.Cells(16, "F").Value
    wks.Cells(LastRow, "GS").Value = ws.Cells(17, "B").Value
    wks.Cells(LastRow, "GT").Value = ws.Cells(17, "C").Value
    wks.Cells(LastRow, "GU").Value = ws.Cells(17, "D").Value
    wks.Cells(LastRow, "GV").Value = ws.Cells(17, "E").Value
    wks.Cells(LastRow, "GW").Value = ws.Cells(17, "F").Value
    wks.Cells(LastRow, "GX").Value = ws.Cells(18, "B").Value
    wks.Cells(LastRow, "GY").Value = ws.Cells(18, "C").Value
    wks.Cells(LastRow, "GZ").Value = ws.Cells(18, "D").Value
    wks.Cells(LastRow, "HA").Value = ws.Cells(18, "E").Value
    wks.Cells(LastRow, "HB").Value = ws.Cells(18, "F").Value
    wks.Cells(LastRow, "HC").Value = ws.Cells(19, "B").Value
    wks.Cells(LastRow, "HD").Value = ws.Cells(19, "C").Value
    wks.Cells(LastRow, "HE").Value = ws.Cells(19, "D").Value
    wks.Cells(LastRow, "HF").Value = ws.Cells(19, "E").Value
    wks.Cells(LastRow, "HG").Value = ws.Cells(19, "F").Value
    wks.Cells(LastRow, "HH").Value = ws.Cells(20, "B").Value
    wks.Cells(LastRow, "HI").Value = ws.Cells(20, "C").Value
    wks.Cells(LastRow, "HJ").Value = ws.Cells(20, "D").Value
    wks.Cells(LastRow, "HK").Value = ws.Cells(20, "E").Value
    wks.Cells(LastRow, "HL").Value = ws.Cells(20, "F").Value
    wks.Cells(LastRow, "HM").Value = ws.Cells(21, "B").Value
    wks.Cells(LastRow, "HN").Value = ws.Cells(21, "C").Value
    wks.Cells(LastRow, "HO").Value = ws.Cells(21, "D").Value
    wks.Cells(LastRow, "HP").Value = ws.Cells(21, "E").Value
    wks.Cells(LastRow, "HQ").Value = ws.Cells(21, "F").Value
    wks.Cells(LastRow, "HR").Value = ws.Cells(22, "B").Value
    wks.Cells(LastRow, "HS").Value = ws.Cells(22, "C").Value
    wks.Cells(LastRow, "HT").Value = ws.Cells(22, "D").Value
    wks.Cells(LastRow, "HU").Value = ws.Cells(22, "E").Value
    wks.Cells(LastRow, "HV").Value = ws.Cells(22, "F").Value
    wks.Cells(LastRow, "HW").Value = ws.Cells(23, "B").Value
    wks.Cells(LastRow, "HX").Value = ws.Cells(23, "C").Value
    wks.Cells(LastRow, "HY").Value = ws.Cells(23, "D").Value
    wks.Cells(LastRow, "HZ").Value = ws.Cells(23, "E").Value
    wks.Cells(LastRow, "IA").Value = ws.Cells(23, "F").Value
    wks.Cells(LastRow, "IB").Value = ws.Cells(24, "B").Value
    wks.Cells(LastRow, "IC").Value = ws.Cells(24, "C").Value
    wks.Cells(LastRow, "ID").Value = ws.Cells(24, "D").Value
    wks.Cells(LastRow, "IE").Value = ws.Cells(24, "E").Value
    wks.Cells(LastRow, "IF").Value = ws.Cells(24, "F").Value
    wks.Cells(LastRow, "IG").Value = ws.Cells(25, "B").Value
    wks.Cells(LastRow, "IH").Value = ws.Cells(25, "C").Value
    wks.Cells(LastRow, "II").Value = ws.Cells(25, "D").Value
    wks.Cells(LastRow, "IJ").Value = ws.Cells(25, "E").Value
    wks.Cells(LastRow, "IK").Value = ws.Cells(25, "F").Value
    wks.Cells(LastRow, "IL").Value = ws.Cells(26, "B").Value
    wks.Cells(LastRow, "IM").Value = ws.Cells(26, "C").Value
    wks.Cells(LastRow, "IN").Value = ws.Cells(26, "D").Value
    wks.Cells(LastRow, "IO").Value = ws.Cells(26, "E").Value
    wks.Cells(LastRow, "IP").Value = ws.Cells(26, "F").Value
 
 
    If blnOpened = True Then
        wkb.Close SaveChanges:=True
    End If
    If MsgBox("Clear values?", vbYesNo, "CLEAR?") = vbYes Then
        Call ClearData
    End If
    Call ToggleEvents(True)
End Sub
 
Sub ToggleEvents(blnState As Boolean)
'Originally written by firefytr
    With Application
        .DisplayAlerts = blnState
        .EnableEvents = blnState
        .ScreenUpdating = blnState
        If blnState Then .CutCopyMode = False
        If blnState Then .StatusBar = False
    End With
End Sub
Function WbOpen(wbName As String) As Boolean
'Originally found written by Jake Marx
    On Error Resume Next
    WbOpen = Len(Workbooks(wbName).Name)
End Function
 
Upvote 0
Thanks Plant007,

I have started doing it manually now and its mind numbing , going to play around with your code , hopefully be able to get it to work for me,

Thanks for sending it on

Anne
 
Upvote 0
good luck - I will keep you updated with any progress this end
 
Upvote 0
Hi Blossomthe2nd

I have done some work with a colleague here and we set up 3 test workbooks (book 1-3) with data in cells A1-G1 in sheets 1-3 of each workbook. The data in cell A1 in the first worksheet in book 1 is 'A11' which is column/book/sheet and this pattern continues up to 'G33' in cell G1 of workbook 3, worksheet 3

We used www.rondebruin.nl/fso.htm (opened as a text file) for assistance and basically copied and pasted another piece of macro code when we hit an error. We started with the sub RDB_Merge_Data_Browse () and then added from there

The code currently merges all the workbooks in a new workbook but only the first worksheet of each workbook - work continues!
Thanks
Andy

Code: 
Private myFiles() As String
Private Fnum As Long
Sub RDB_Merge_Data_Browse()
    Dim myFiles As Variant
    Dim myCountOfFiles As Long
    Dim oApp As Object
    Dim oFolder As Variant
    Set oApp = CreateObject("Shell.Application")
    Set oFolder = oApp.BrowseForFolder(0, "Select folder", 512)
    If Not oFolder Is Nothing Then
'        myCountOfFiles = Get_File_Names( _
'                         MyPath:=oFolder.Self.Path, _
'                         Subfolders:=True, _
'                         ExtStr:="*.xl*", _
'                         myReturnedFiles:=myFiles)
 
     myCountOfFiles = Get_File_Names(MyPath:=oFolder.Self.Path, Subfolders:=True, ExtStr:="*.xl*", myReturnedFiles:=myFiles)
 
        If myCountOfFiles = 0 Then
            MsgBox "No files that match the ExtStr in this folder"
            Exit Sub
        End If
        Get_Data _
                FileNameInA:=True, _
                PasteAsValues:=True, _
                SourceShName:="", _
                SourceShIndex:=1, _
                SourceRng:="A1:G1", _
                StartCell:="", _
                myReturnedFiles:=myFiles
    End If
End Sub
 
 
Function Get_File_Names(MyPath As String, Subfolders As Boolean, _
                        ExtStr As String, myReturnedFiles As Variant) As Long
    Dim Fso_Obj As Object, RootFolder As Object
    Dim SubFolderInRoot As Object, file As Object
    'Add a slash at the end if the user forget it
    If Right(MyPath, 1) <> "\" Then
        MyPath = MyPath & "\"
    End If
    'Create FileSystemObject object
    Set Fso_Obj = CreateObject("Scripting.FileSystemObject")
    Erase myFiles()
    Fnum = 0
    'Test if the folder exist and set RootFolder
    If Fso_Obj.FolderExists(MyPath) = False Then
        Exit Function
    End If
    Set RootFolder = Fso_Obj.GetFolder(MyPath)
    'Fill the array(myFiles)with the list of Excel files in the folder(s)
    'Loop through the files in the RootFolder
    For Each file In RootFolder.Files
        If LCase(file.Name) Like LCase(ExtStr) Then
            Fnum = Fnum + 1
            ReDim Preserve myFiles(1 To Fnum)
            myFiles(Fnum) = MyPath & file.Name
        End If
    Next file
    'Loop through the files in the Sub Folders if SubFolders = True
    If Subfolders Then
        Call ListFilesInSubfolders(OfFolder:=RootFolder, FileExt:=ExtStr)
    End If
    myReturnedFiles = myFiles
    Get_File_Names = Fnum
End Function
Sub Get_Data(FileNameInA As Boolean, PasteAsValues As Boolean, SourceShName As String, _
             SourceShIndex As Integer, SourceRng As String, StartCell As String, myReturnedFiles As Variant)
    Dim SourceRcount As Long
    Dim SourceRange As Range, destrange As Range
    Dim mybook As Workbook, BaseWks As Worksheet
    Dim rnum As Long, CalcMode As Long
    Dim SourceSh As Variant
    Dim sh As Worksheet
    Dim I As Long
    'Change ScreenUpdating, Calculation and EnableEvents
    With Application
        CalcMode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    'Add a new workbook with one sheet named "Combine Sheet"
    Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
    BaseWks.Name = "Combine Sheet"
    'Set start row for the Data
    rnum = 1
    'Check if we use a named sheet or the index
    If SourceShName = "" Then
        SourceSh = SourceShIndex
    Else
        SourceSh = SourceShName
    End If
    'Loop through all files in the array(myFiles)
    For I = LBound(myReturnedFiles) To UBound(myReturnedFiles)
        Set mybook = Nothing
        On Error Resume Next
        Set mybook = Workbooks.Open(myReturnedFiles(I))
        On Error GoTo 0
        If Not mybook Is Nothing Then
            If LCase(SourceShName) <> "all" Then
                'Set SourceRange and check if it is a valid range
                On Error Resume Next
                If StartCell <> "" Then
                    With mybook.Sheets(SourceSh)
                        Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells))
                        'Test if the row of the last cell >= then the row of the StartCell
                        If RDB_Last(1, .Cells) < .Range(StartCell).Row Then
                            Set SourceRange = Nothing
                        End If
                    End With
                Else
                    With mybook.Sheets(SourceSh)
                        Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng))
                    End With
                End If
                If Err.Number > 0 Then
                    Err.Clear
                    Set SourceRange = Nothing
                Else
                    'if SourceRange use all columns then skip this file
                    If SourceRange.Columns.Count >= BaseWks.Columns.Count Then
                        Set SourceRange = Nothing
                    End If
                End If
                On Error GoTo 0
                If Not SourceRange Is Nothing Then
                    'Check if there enough rows to paste the data
                    SourceRcount = SourceRange.Rows.Count
                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                        MsgBox "Sorry there are not enough rows in the sheet to paste"
                        mybook.Close savechanges:=False
                        BaseWks.Parent.Close savechanges:=False
                        GoTo ExitTheSub
                    End If
                    'Set the destination cell
                    If FileNameInA = True Then
                        Set destrange = BaseWks.Range("B" & rnum)
                        With SourceRange
                            BaseWks.Cells(rnum, "A"). _
                                    Resize(.Rows.Count).Value = myReturnedFiles(I)
                        End With
                    Else
                        Set destrange = BaseWks.Range("A" & rnum)
                    End If
                    'Copy/paste the data
                    If PasteAsValues = True Then
                        With SourceRange
                            Set destrange = destrange. _
                                            Resize(.Rows.Count, .Columns.Count)
                        End With
                        destrange.Value = SourceRange.Value
                    Else
                        SourceRange.Copy destrange
                    End If
                    rnum = rnum + SourceRcount
                End If
                'Close the workbook without saving
                mybook.Close savechanges:=False
            Else
                'Loop through all sheets in mybook
                For Each sh In mybook.Worksheets
                    'Set SourceRange and check if it is a valid range
                    On Error Resume Next
                    If StartCell <> "" Then
                        With sh
                            Set SourceRange = .Range(StartCell & ":" & RDB_Last(3, .Cells))
                            If RDB_Last(1, .Cells) < .Range(StartCell).Row Then
                                Set SourceRange = Nothing
                            End If
                        End With
                    Else
                        With sh
                            Set SourceRange = Application.Intersect(.UsedRange, .Range(SourceRng))
                        End With
                    End If
                    If Err.Number > 0 Then
                        Err.Clear
                        Set SourceRange = Nothing
                    Else
                        'if SourceRange use almost all columns then skip this file
                        If SourceRange.Columns.Count > BaseWks.Columns.Count - 2 Then
                            Set SourceRange = Nothing
                        End If
                    End If
                    On Error GoTo 0
                    If Not SourceRange Is Nothing Then
                        'Check if there enough rows to paste the data
                        SourceRcount = SourceRange.Rows.Count
                        If rnum + SourceRcount >= BaseWks.Rows.Count Then
                            MsgBox "Sorry there are not enough rows in the sheet to paste"
                            mybook.Close savechanges:=False
                            BaseWks.Parent.Close savechanges:=False
                            GoTo ExitTheSub
                        End If
                        'Set the destination cell
                        If FileNameInA = True Then
                            Set destrange = BaseWks.Range("C" & rnum)
                            With SourceRange
                                BaseWks.Cells(rnum, "A"). _
                                        Resize(.Rows.Count).Value = myReturnedFiles(I)
                                BaseWks.Cells(rnum, "B"). _
                                        Resize(.Rows.Count).Value = sh.Name
                            End With
                        Else
                            Set destrange = BaseWks.Range("A" & rnum)
                        End If
                        'Copy/paste the data
                        If PasteAsValues = True Then
                            With SourceRange
                                Set destrange = destrange. _
                                                Resize(.Rows.Count, .Columns.Count)
                            End With
                            destrange.Value = SourceRange.Value
                        Else
                            SourceRange.Copy destrange
                        End If
                        rnum = rnum + SourceRcount
                    End If
                Next sh
                'Close the workbook without saving
                mybook.Close savechanges:=False
            End If
        End If
        'Open the next workbook
    Next I
    'Set the column width in the new workbook
    BaseWks.Columns.AutoFit
ExitTheSub:
    'Restore ScreenUpdating, Calculation and EnableEvents
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = CalcMode
    End With
End Sub
Sub ListFilesInSubfolders(OfFolder As Object, FileExt As String)
'Origenal SubFolder code from Chip Pearson
'http://www.cpearson.com/Excel/RecursionAndFSO.htm
'Changed by Ron de Bruin, 27-March-2008
    Dim SubFolder As Object
    Dim fileInSubfolder As Object
    For Each SubFolder In OfFolder.Subfolders
        ListFilesInSubfolders OfFolder:=SubFolder, FileExt:=FileExt
        For Each fileInSubfolder In SubFolder.Files
            If LCase(fileInSubfolder.Name) Like LCase(FileExt) Then
                Fnum = Fnum + 1
                ReDim Preserve myFiles(1 To Fnum)
                myFiles(Fnum) = SubFolder & "\" & fileInSubfolder.Name
            End If
        Next fileInSubfolder
    Next SubFolder
End Sub
 
Function RDB_Last(choice As Integer, rng As Range)
'Ron de Bruin, 5 May 2008
' 1 = last row
' 2 = last column
' 3 = last cell
    Dim lrw As Long
    Dim lcol As Integer
    Select Case choice
    Case 1:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
        On Error GoTo 0
    Case 2:
        On Error Resume Next
        RDB_Last = rng.Find(What:="*", _
                            after:=rng.Cells(1), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
        On Error GoTo 0
    Case 3:
        On Error Resume Next
        lrw = rng.Find(What:="*", _
                       after:=rng.Cells(1), _
                       Lookat:=xlPart, _
                       LookIn:=xlFormulas, _
                       SearchOrder:=xlByRows, _
                       SearchDirection:=xlPrevious, _
                       MatchCase:=False).Row
        On Error GoTo 0
        On Error Resume Next
        lcol = rng.Find(What:="*", _
                        after:=rng.Cells(1), _
                        Lookat:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Column
        On Error GoTo 0
        On Error Resume Next
        RDB_Last = rng.Parent.Cells(lrw, lcol).Address(False, False)
        If Err.Number > 0 Then
            RDB_Last = rng.Cells(1).Address(False, False)
            Err.Clear
        End If
        On Error GoTo 0
    End Select
End Function
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Solved
EXCEL VBA - help to copy filtered data from one workbook to multiple new workbooks and save code.
Replies
2
Views
443
Jordan2
J
J
  • Question Question
Consolidate data from multiple sheets based on values selected in dependent list boxes
Replies
0
Views
557
jconda
J
L
  • Question Question
Step 1: Can you Loop Through Multiple Excel worksheets in one workbook (Copy and paste all to new worksheet or Workbook)
Replies
9
Views
746
Micron
M
H
  • Solved
Macro to Copy Data from Sheet BR1 Shirt Sales to Last Sheet
Replies
9
Views
734
kevin9999
K
P
  • Question Question
VBA to copy multiple worksheets and either rename sheet with file name or add column with filename
Replies
5
Views
2K
I_know_nuffin
I

Forum statistics

Threads
1,224,616
Messages
6,179,909
Members
452,949
Latest member
beartooth91

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top