Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Hi,
Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
You can find a example here that use a function to find the last row
http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Ron,
Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Hi
Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Ron,
Thanks very much for replying. I see what you mean, I'll give it a go and let you know how I get on. Regards and many thanks Chris "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Hi Ron,
I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Hi Chris
If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc 'WB will always refer to the source Workbook that 'you are interrogating at the time Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc WBn = WB.Name WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row 'Copy the data across CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value ' 'Put the filename in the first Col as an index value ' CurWks.Cells(lrow + 1, "A").Resize(WBlstrw - Hdrs, 1).Value = WBn lrow = lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub The problem I have is that the files I get containing the data I extract have changed. The above macro assumes that there is always data in the A column and uses this as a guide to copy the data within the whole row. This is now not always the case. With my very limited VB knowledge, by changing things around, adding and removing the code I think I've located the line that needs to change as this: 'WBlstrw = WB.Sheets(1).Cells(Rows.Count, "A").End(xlUp).Row' I am fairly new to VB and not that confident and I've tried to change the Cells(Row to Range, but this doesn't work. Could somebody tell me please how I could change the code so it looks at a range rather than column A. Many thanks and regards Chris |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Hi Ron,
I've made the change, unfortunately as before it seems to run, but nothing happens! I was thinking about a couple of things where the problem may be. Wherabouts should this be: Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function At the moment it's at the very beginning of my coding, and it's split with the line across the page almost as if it's two separate bits of coding. I did try and add it in the middle of the rest of coding, but it didn't even run. The second thing is. Does 'weeks' relate to a file that it is looking for or, is it creating a file called 'weeks'? Thanks Ron for bearing with me and for your help Regards Chris "Ron de Bruin" wrote: Hi Chris If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
There are a few problems in your code
I post a example within a hour -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I've made the change, unfortunately as before it seems to run, but nothing happens! I was thinking about a couple of things where the problem may be. Wherabouts should this be: Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function At the moment it's at the very beginning of my coding, and it's split with the line across the page almost as if it's two separate bits of coding. I did try and add it in the middle of the rest of coding, but it didn't even run. The second thing is. Does 'weeks' relate to a file that it is looking for or, is it creating a file called 'weeks'? Thanks Ron for bearing with me and for your help Regards Chris "Ron de Bruin" wrote: Hi Chris If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Ok
Copy both the function in a normal module This is my tester so change the path to yours. And also this line If LCase(Left(FNames, 4)) = "book" Then Now it only run for csv file names that start with book Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "C:\Users\Ron\test" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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)) = "book" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:IV" & lrow) 'Copy from A2:IV? (till the last row with data on your sheet) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") 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 mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in message ... There are a few problems in your code I post a example within a hour -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I've made the change, unfortunately as before it seems to run, but nothing happens! I was thinking about a couple of things where the problem may be. Wherabouts should this be: Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function At the moment it's at the very beginning of my coding, and it's split with the line across the page almost as if it's two separate bits of coding. I did try and add it in the middle of the rest of coding, but it didn't even run. The second thing is. Does 'weeks' relate to a file that it is looking for or, is it creating a file called 'weeks'? Thanks Ron for bearing with me and for your help Regards Chris "Ron de Bruin" wrote: Hi Chris If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() Dim Lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet Dim sh As Worksheet Dim DestSh As Worksheet Dim shLast As Long Dim Last As Long On Error Resume Next Set CurWkb = Workbooks.Add Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False With CurWks .Activate .UsedRange.Delete End With Lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = "PAck*.csv" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc Set WB = Application.Workbooks.Open(Filename:=.FoundFiles(i )) If i = 1 Then NumCols = WB.Sheets(1).UsedRange.Column - 1 + _ WB.Sheets(1).UsedRange.Columns.Count CurWks.Cells(Hdrs, "A").Resize(1, NumCols).Value = _ WB.Worksheets(1).Range("A1").Resize(1, NumCols).Value End If Application.StatusBar = "Currently Processing file " & i & " of " & ffc sh.Range(sh.Rows(3), sh.Rows(shLast)).Copy DestSh.Cells(Last + 1, "A") CurWks.Cells(Lrow + 1, "A").Resize(WBlstrw - Hdrs, NumCols).Value = _ WB.Worksheets(1).Range("A2").Resize(WBlstrw - Hdrs, NumCols).Value Lrow = Lrow + (WBlstrw - Hdrs) WB.Close savechanges:=False Next End With Set WB = Nothing Set CurWks = Nothing Set CurWkb = Nothing Application.ScreenUpdating = True Application.StatusBar = False End Sub Any help would be gratefully appreciated. many thanks and kind regards Chris "Ron de Bruin" wrote: You can find a example here that use a function to find the last row http://www.rondebruin.nl/copy3.htm -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi, Wonder if someone acn help me please. I am using, and have been for sometime some great coding below, (admitedly not mine, a great programmer called Ken Wright) to copy rows of data from multiple workbooks and pasting them into one master sheet. The macro also copies the header of the first workbook it extracts the data from and ignores the headers in the rest. Sub CopyFromMultipleFiles() Dim lrow As Long Dim Hdrs As Long Dim NumCols As Long Dim ffc As Long Dim i As Long Dim R As Integer Dim WBn As String Dim rng As Range Dim WB As Workbook Dim WBr As Range Dim WBlstrw As Long Dim CurWkb As Workbook Dim CurWks As Worksheet Dim CurWksLrow As Long Dim strStartDir As String Dim UserFile As String Dim Sht As Worksheet On Error Resume Next UserFile = PickFolder(strStartDir) If UserFile = "" Then MsgBox "Canceled" Exit Sub End If Set CurWkb = Workbooks.Add 'CurWks will always refer to the Summary worksheet you are creating Set CurWks = CurWkb.Worksheets(1) Application.ScreenUpdating = False 'Clear out the Summary worksheet With CurWks .Activate .UsedRange.Delete End With lrow = 1 Hdrs = 1 With Application.FileSearch .SearchSubFolders = True .NewSearch .Filename = ".xls" .LookIn = UserFile .FileType = msoFileTypeExcelWorkbooks .Execute ffc = .FoundFiles.Count For i = 1 To ffc |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
Ron,
Thanks, it works a treat. Well, that's it, it all works great. Thanks you so very much for your continued help and patience. It has really helped me out. Many thanks and kind regards Chris "Ron de Bruin" wrote: The macro doesn't work if I save this within the default 'PERSONAL.xls' macro folder, any ideas? Set basebook = ThisWorkbook Change to ActiveWorkbook -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks so very much for the continued help, it really is appreciated. I've been working on this for the last few hours and I've got the coding to work, but I've also found out where the problem is. The macro doesn't work if I save this within the default 'PERSONAL.xls' macro folder, any ideas? Many thanks once again and kind regards "Ron de Bruin" wrote: Ok Copy both the function in a normal module This is my tester so change the path to yours. And also this line If LCase(Left(FNames, 4)) = "book" Then Now it only run for csv file names that start with book Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "C:\Users\Ron\test" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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)) = "book" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:IV" & lrow) 'Copy from A2:IV? (till the last row with data on your sheet) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") 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 mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in message ... There are a few problems in your code I post a example within a hour -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I've made the change, unfortunately as before it seems to run, but nothing happens! I was thinking about a couple of things where the problem may be. Wherabouts should this be: Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function At the moment it's at the very beginning of my coding, and it's split with the line across the page almost as if it's two separate bits of coding. I did try and add it in the middle of the rest of coding, but it didn't even run. The second thing is. Does 'weeks' relate to a file that it is looking for or, is it creating a file called 'weeks'? Thanks Ron for bearing with me and for your help Regards Chris "Ron de Bruin" wrote: Hi Chris If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Merge Multiple Workbooks
You are welcome
Thanks for the feedback -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks, it works a treat. Well, that's it, it all works great. Thanks you so very much for your continued help and patience. It has really helped me out. Many thanks and kind regards Chris "Ron de Bruin" wrote: The macro doesn't work if I save this within the default 'PERSONAL.xls' macro folder, any ideas? Set basebook = ThisWorkbook Change to ActiveWorkbook -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks so very much for the continued help, it really is appreciated. I've been working on this for the last few hours and I've got the coding to work, but I've also found out where the problem is. The macro doesn't work if I save this within the default 'PERSONAL.xls' macro folder, any ideas? Many thanks once again and kind regards "Ron de Bruin" wrote: Ok Copy both the function in a normal module This is my tester so change the path to yours. And also this line If LCase(Left(FNames, 4)) = "book" Then Now it only run for csv file names that start with book Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "C:\Users\Ron\test" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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)) = "book" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:IV" & lrow) 'Copy from A2:IV? (till the last row with data on your sheet) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") 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 mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "Ron de Bruin" wrote in message ... There are a few problems in your code I post a example within a hour -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I've made the change, unfortunately as before it seems to run, but nothing happens! I was thinking about a couple of things where the problem may be. Wherabouts should this be: Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function At the moment it's at the very beginning of my coding, and it's split with the line across the page almost as if it's two separate bits of coding. I did try and add it in the middle of the rest of coding, but it didn't even run. The second thing is. Does 'weeks' relate to a file that it is looking for or, is it creating a file called 'weeks'? Thanks Ron for bearing with me and for your help Regards Chris "Ron de Bruin" wrote: Hi Chris If LCase(Left(FNames, 4)) = "weeks" Then weeks are 5 characters not 4 -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Hi Ron, I must be missing somehting obvious here! I've taken the coding that you suggested and changed the file path, the range that I want the code to look at and the file extension. The macro runs but it doesn't extract the data. Any ideas please? Kind regards Chris Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Sub Example7() Dim basebook As Workbook Dim mybook As Workbook Dim sourceRange As Range Dim destrange As Range Dim rnum As Long Dim lrow As Long Dim SourceRcount As Long Dim FNames As String Dim MyPath As String Dim SaveDriveDir As String SaveDriveDir = CurDir MyPath = "D:\My Documents" ChDrive MyPath ChDir MyPath FNames = Dir("*.csv") 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 rnum = 1 Do While FNames < "" If LCase(Left(FNames, 4)) = "weeks" Then Set mybook = Workbooks.Open(FNames) lrow = LastRow(mybook.Sheets(1)) Set sourceRange = mybook.Worksheets(1).Range("A2:Q" & lrow) SourceRcount = sourceRange.Rows.Count Set destrange = basebook.Worksheets(1).Cells(rnum, "A") sourceRange.Copy destrange mybook.Close False rnum = rnum + SourceRcount End If FNames = Dir() Loop ChDrive SaveDriveDir ChDir SaveDriveDir Application.ScreenUpdating = True End Sub "Ron de Bruin" wrote: Hi Try to forget FileSearch. In Office 2007 it is not available anymore and it is not always working correct You can use the code from my site and look in this example http://www.rondebruin.nl/copy3.htm#range2 Where I test the file name with If LCase(Left(FNames, 4)) = "week" Then You can build that test in this macro http://www.rondebruin.nl/copy3.htm#header -- Regards Ron de Bruin http://www.rondebruin.nl/tips.htm "ir26121973" wrote in message ... Ron, Thanks for getting back to me. Like I said I am very new to VB and I do struggle to understand some of code. I looked at the example of codes that you gave me the link to and what I've tried to do is take the line that copies the rows of data and import into the macro that I was using because I really needed the code to look for specific file names and also to copy the header from the first file it extracts and ignore the rest. The problem I have is that it only copies the header and not the data. From the code below could you perhaps give me a little guidance as to where I am going wrong. Sub Copy_From_Multiple_P14_Files() |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Completely Merge Multiple Workbooks? | Excel Discussion (Misc queries) | |||
Merge workbooks | Excel Discussion (Misc queries) | |||
merge workbooks | Excel Worksheet Functions | |||
Trying to Merge 2 Workbooks | Excel Discussion (Misc queries) | |||
Merge Workbooks? | Excel Programming |