Copy Excel Data from One Excel work book to another.

[teja1234]

Hi All,

Can any please tell me how to copy data from One Excel file to another excel file. I tried some code but i am not able to do that.
If any one share the working code for same it will be great help.

Thanks in Advance
Teja

 

[PHV]

I tried some code
Which code ?
Where are you stuck ?

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[teja1234]

Hi PHV,
Thanks for your reply. Below is the code i tried

Sub CopyDataOfWorkbooks()

Dim objWorkbook As Workbook, objMainWorkbook As Workbook
Dim ArrayWorkbooks() As String
Dim i As Byte

' Setings
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
ReDim ArrayWorkbooks(1 To 2)
ArrayWorkbooks(1) = "c:\Documents and Settings\admin\Desktop\Aezaz\Test1.xls"
ArrayWorkbooks(2) = "c:\Documents and Settings\admin\Desktop\Aezaz\Test2.xls"
'!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

Set objMainWorkbook = ActiveWorkbook

For i = 1 To UBound(ArrayWorkbooks)
If Open_Workbook(ArrayWorkbooks(i), objWorkbook) Then
Call CopyEachSheet(objWorkbook, objMainWorkbook)
End If
Next i

Set objMainWorkbook = Nothing: Set objWorkbook = Nothing

MsgBox "Finished"

End Sub
Function Open_Workbook(strFileName As String, objWorkbook As Workbook) As Boolean

If IsMissing(strFileName) = True Or Len(strFileName) < 6 Then
Exit Function
End If

On Error Resume Next
Set objWorkbook = Workbooks.Open(Filename:=strFileName)
If Err.Number <> 0 Then
Open_Workbook = False
Else
Open_Workbook = True
End If
On Error GoTo 0

End Function
Sub CopyEachSheet(objWorkbook As Workbook, objMainWorkbook As Workbook)

Dim TempSheet As Worksheet
Dim strFreeAddress As String

For Each TempSheet In objWorkbook.Worksheets
TempSheet.UsedRange.Copy
strFreeAddress = FindFreeCells(objMainWorkbook, TempSheet.Name)
Sheets(TempSheet.Name).Range(strFreeAddress).PasteSpecial Paste:=xlPasteAll
Next TempSheet

Application.CutCopyMode = False
Application.DisplayAlerts = False
objWorkbook.Close SaveChanges:=False
Application.DisplayAlerts = True

Set TempSheet = Nothing: Set objMainWorkbook = Nothing: Set objWorkbook = Nothing
End Sub
Function FindFreeCells(objMainWorkbook As Workbook, strSheetName As String) As String

objMainWorkbook.Activate
' If objMainWorkbook doesn't contain sheet same name, create it
On Error Resume Next
With Sheets(strSheetName)
If Err.Number <> 0 Then
objMainWorkbook.Worksheets.Add(before:=Worksheets(1)).Name = strSheetName
FindFreeCells = "A1"
On Error GoTo 0
Else
FindFreeCells = .Cells(.Cells.SpecialCells(xlCellTypeLastCell).Row, 1).Address
End If
End With

Set objMainWorkbook = Nothing

End Function


Please if u have any other code for same please share with me.

Thanks Teja