Copy Multiple Files To Master Copy

[hobbiton73]

I wonder whether someone may be able to help me please.


For some time now, I've been trying to put together a macro which allows the user to select Source Files by way of a button select in the 'Destination (Master File). VB is not my strongest subject, so I've not been able to get this to work.


From all the research I've done I started to use the following as a starting point, but there seems to be an inherent bug in the code because although the macro correctly copies the data it adds erroneous lines of data when pasted, so I think I need to start from the beginning.

[pre]

Sub CopyData()
Dim wsT As Worksheet
Dim wsF As Worksheet
Dim lRow(1) As Long
Dim iCol As Integer 

Dim sFile As String 

sFile = Application.GetOpenFilename("Excel Files (*.xls), *.xls")
If sFile = "False" Then
Exit Sub
End If
Set wsT = ThisWorkbook.Sheets("Combined")
Workbooks.Open sFile
Set wsF = ActiveSheet 

'get size of data
lRow(0) = wsF.Cells.Find(What:="*", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
iCol = wsF.Cells.Find(What:="*", _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column 

lRow(1) = wsT.Cells.Find(What:="*", _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row + 1
If lRow(1) + lRow(0) > Rows.Count Then
MsgBox "WorkSheet To full to Copy To", vbInformation
Else
wsT.Range("A" & lRow(1) & ":" & Cells(lRow(1) + lRow(0), iCol).Address).Value _
= wsF.Range("A5:" & Cells(lRow(0), iCol).Address).Value
End If
ActiveWorkbook.Close False
End Sub

[/pre]

If at all possible, I would be grateful if someone could offer a little guidance on how I may go about achieving the following:


A macro, which for every 'Source File' selected, automatically copies the data from 'Row 5' for the 'Ranges A:AJ and AL:AX' until it reaches a blank row, then closes that file.


Then, with the information that has been copied, I'd be very grateful if someone could then show me how to write the code whereby it searches for the next available blank row in the 'Destination' File, again starting at 'Row 5' for the 'Ranges A:AJ and AL:AX' pasting both the cell value and any formatting or comments into those cells.


Obviously as I copy data from the 'Source Files', I would be most grateful if someone could show me how to make sure that before the data is pasted, it searches for the next available blank row, so in essence each set of data is paste underneath each other.


Many thanks and kind regards


Chris

 

[shrivallabha]

Hello Chris,


Do not cross post the same topic on more than one sites. Since you are posting for the first time so you may not be aware of it.


Cross-posted here:

http://www.vbaexpress.com/forum/showthread.php?p=278066#post278066


Please read: http://www.excelguru.ca/forums/faq.php?faq=crossposting


Since you've posted on helpful forums you will get help for what you need. Good luck!

 

[hobbiton73]

Hi, my sincere apologies, I wasn't aware of this. Although the code samples are different, they are for the same task. I have marked the other post as 'Solved.


Once again my apologies and thank you for pointing this out.


Many thanks and kind regards

 

[hobbiton73]

Hi all, I made a mess with the cross posting.


Since my original post on this site I have done some further work on this. I now have a script which copies and pastes the correct information as shown below.

[pre]

Sub Merge() 

Dim DestCell As Range
Dim DataColumn As Variant
Dim NumberOfColumns As Variant
Dim WB As Workbook
Dim DestWB As Workbook
Dim WS As Worksheet
Dim FileNames As Variant
Dim N As Long
Dim R As Range
Dim StartRow As Long
Dim LastRow As Long
Dim RowNdx As Long 

Set DestWB = ActiveWorkbook 

Set DestCell = DestWB.Worksheets(1).Range("A5") 

DataColumn = "A" 

NumberOfColumns = 36 

StartRow = 5 

FileNames = Application.GetOpenFilename( _
filefilter:="Excel Files (*.xls*),*.xls*", _
Title:="Select the workbooks to merge.", MultiSelect:=True)
If IsArray(FileNames) = False Then
If FileNames = False Then
Exit Sub
End If
End If 

For N = LBound(FileNames) To UBound(FileNames) 

Set WB = Workbooks.Open(Filename:=FileNames(N), ReadOnly:=True) 

For Each WS In WB.Worksheets
With WS 

If WS.UsedRange.Cells.Count > 1 Then 

LastRow = .Cells(.Rows.Count, DataColumn). _
End(xlUp).Row 

For RowNdx = StartRow To LastRow 

.Cells(RowNdx, DataColumn). _
Resize(1, NumberOfColumns).Copy _
Destination:=DestCell 

Set DestCell = DestCell(2, 1)
Next RowNdx
End If
End With
Next WS 

WB.Close savechanges:=False
Next N 

End Sub

[/pre]

Unfortunately, although I can manage to get the copy and paste function to work, I'm having problems in that every time I open a 'Source' file and copy the data, it pastes the data in the Destination file overwriting any existing data.


Could someone perhaps provide some guidance please, on how I may go about changing this, so that the data is pasted into the next blank row, rather than overwriting what is already there.


Many thanks and kind regards

 

[Marc L]

Hi hobbit !


DataColumn should be set to 1.


Certainly the source of overwriting is the copy destination …


So try to replace the line  

Set DestCell = DestCell(2, 1)


                 by this one :   [code]Set DestCell = DestWB.Worksheets(1).DestCell(2)

EDIT : if the problem remains, as you could see in the Copy VBA Help,

          you have to clearly explicit the destination like this :   Destination:=DestWB.Worksheets(1).DestCell[/code]

 

[hobbiton73]

Hi @Marc, thank you very much for taking the time to reply to my post.


I was lucky enough to receive your reply and another from the sister site 'VBA Express' with the same answer, and it works great.


Once again many thanks and kind regards