Combine code?

[leduyhung1112]

Hello,

I am trying to copy the source data into all reports file located in my folder and it is working as i expected. However, i have to choose the same source file every time the loop go through one excel report in the folder. Would someone please help me to modify the code so that i only need to choose one time, then the data will be copied to all other excel file?.

Here are my code:

Public Sub refreshXLS()
Dim fso As Object
Dim folder As Object
Dim file As Object
Path = "P:\My Documents\RCA Report\Weekly Report"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)

With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.AskToUpdateLinks = False
End With


For Each file In folder.Files
If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then
Workbooks.Open Path & file.Name

ActiveWorkbook.Sheets(1).Range("A2:CB2", Range("A1").End(xlDown)).ClearContents
Call Foo
ActiveWorkbook.Close True
End If
Next


With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.AskToUpdateLinks = True
End With
End Sub


Sub Foo()
Dim vFile As Variant
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet




Set wbCopyTo = ActiveWorkbook
Set wsCopyTo = ActiveSheet
'-------------------------------------------------------------
'Open file with data to be copied


vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & _
"*.xl*", 1, "Select Excel File", "Open", False)


'If Cancel then Exit
If TypeName(vFile) = "Boolean" Then
Exit Sub
Else
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)
End If


'--------------------------------------------------------------
'Copy Range
wsCopyFrom.Range("A2:CB2", Range("A1").End(xlDown)).Copy
wsCopyTo.Range("A2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False




'Close file that was opened
wbCopyFrom.Close SaveChanges:=False


End Sub

 

[wideboydixon]

Untested but I think this should achieve what you're after:

Public Sub refreshXLS()

Dim fso As Object
Dim folder As Object
Dim file As Object
Dim vFile As Variant
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet

Path = "P:\My Documents\RCA Report\Weekly Report\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)

vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", False)
If TypeName(vFile) = "Boolean" Then Exit Sub

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
End With

' Open source file
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = wbCopyFrom.Worksheets(1)

For Each file In folder.Files
    If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then
        Set wbCopyTo = Workbooks.Open(Path & file.Name)
        Set wsCopyTo = ActiveSheet
        wsCopyTo.Range("A2:CB2", Range("A1").End(xlDown)).ClearContents
        wsCopyFrom.Range("A2:CB2", Range("A1").End(xlDown)).Copy
        wsCopyTo.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wbCopyTo.Close True
    End If
Next

'Close file that was opened
wbCopyFrom.Close SaveChanges:=False

With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With

End Sub

WBD

 

[leduyhung1112]

Thanks for answering my post.

I have tested your code. I got the error: Method 'Range' of Object'_Worksheet' failed on this line : wsCopyFrom.Range("A2:CB2", Range("A1").End(xlDown)).Copy
Would you please give me explanation for this? i am quite new with Excel VBA.

Thanks

 

[wideboydixon]

Hi,

That line was from your original code; I just moved it out of the Foo() sub. Was it working before? It does look a little odd. How about:

Public Sub refreshXLS()


Dim fso As Object
Dim folder As Object
Dim file As Object
Dim vFile As Variant
Dim wbCopyFrom As Workbook
Dim wsCopyFrom As Worksheet
Dim wbCopyTo As Workbook
Dim wsCopyTo As Worksheet


Path = "P:\My Documents\RCA Report\Weekly Report\"
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(Path)


vFile = Application.GetOpenFilename("Excel Files (*.xl*)," & "*.xl*", 1, "Select Excel File", "Open", False)
If TypeName(vFile) = "Boolean" Then Exit Sub


With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
    .AskToUpdateLinks = False
End With


' Open source file
Set wbCopyFrom = Workbooks.Open(vFile)
Set wsCopyFrom = ActiveSheet


For Each file In folder.Files
    If Right(file.Name, 4) = "xlsx" Or Right(file.Name, 3) = "xls" Then
        Set wbCopyTo = Workbooks.Open(Path & file.Name)
        Set wsCopyTo = ActiveSheet
        wsCopyTo.Range("A2:CB2", Range("A1").End(xlDown)).ClearContents
        With wsCopyFrom
            .Range(.Cells(2, "A"), .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row, "CB")).Copy
        End With
        wsCopyTo.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        wbCopyTo.Close True
    End If
Next


'Close file that was opened
wbCopyFrom.Close SaveChanges:=False


With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
    .AskToUpdateLinks = True
End With


End Sub

WBD

 

[leduyhung1112]

Hi,

The code runs nearly perfect. I still got the error: The operation requires the merged cells to be identically sized on this line:

wsCopyTo.Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

I have search for solution such as select all data --> format cell --> Alignment --> uncheck merged cell. but it does not work. Would you please help?

Regards,
Hung