Open spreadsheet and copy data from 1st to 2nd spreadsheet

[j.millar]

Hello,

I'm trying to arrange add a Macro button to my spreadsheet so that it will open up a previously saved spreadsheet, search for the project code and copy the data from certain cells and paste into the 2nd spreadsheet.

I recorded the following macro, but that limits it to a certain row. I was hoping to get it to loop through update each row and update the corresponding row in the second spreadsheet

Sub Macro1()
'
' Macro1 Macro
'
'
    Workbooks.Open Filename:= _
        "G:\Projects\Annual Planning\2010-11\Annual Plan2010_11Combined(working copy).xlsx" _
        , UpdateLinks:=0
    Windows("Reports finalised1011.xlsm").Activate
    Range("B3").Select 'This is the cell that has the project code to be searched
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    Cells.Find(What:="NI37-11", After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Activate 'NI37-11 is the contents of cell "B3" 
    Windows("Reports finalised1011.xlsm").Activate
    Range("D3").Select 'Column D of the selected Row is to be copied to column AA of the Annual Plan
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    ActiveWindow.ScrollColumn = 2
    ActiveWindow.ScrollColumn = 3
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    ActiveWindow.ScrollColumn = 9
    ActiveWindow.ScrollColumn = 10
    Range("AA8").Select
    ActiveSheet.Paste
    Windows("Reports finalised1011.xlsm").Activate
    Range("E3").Select 'column E to be copied to column AB of Annual Plan spreadsheet
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    Range("AB8").Select
    ActiveSheet.Paste
    Windows("Reports finalised1011.xlsm").Activate
    Range("F3").Select 'Column F to be copied to column O of the Annual Plan spreadsheet
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    ActiveWindow.ScrollColumn = 11
    Windows("Reports finalised1011.xlsm").Activate
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 8
    Range("O3").Select 'Column O is to be copied to column T of the Annual Plan
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    Range("T8").Select 
    ActiveSheet.Paste
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Windows("Reports finalised1011.xlsm").Activate
    ActiveWindow.ScrollColumn = 7
    ActiveWindow.ScrollColumn = 6
    ActiveWindow.ScrollColumn = 5
    ActiveWindow.ScrollColumn = 4
    ActiveWindow.ScrollColumn = 3
    Range("B4").Select 'Start the next row again...
    Application.CutCopyMode = False
    Selection.Copy
    Windows("Annual Plan2010_11Combined(working copy).xlsx").Activate
    Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
        xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False).Activate
    Windows("Reports finalised1011.xlsm").Activate
End Sub

Any help would be appreciated...

Thanks!

 

[AlphaFrog]

Try something like this...

Sub Update_Annual_Plan()

    Dim wbPlan As Workbook
    Dim wsB As Worksheet, rngB As Range, cellB As Range, FoundB As Range
    
    Set wsB = ActiveSheet
    Set rngB = Range("B3:B" & Range("B" & Rows.Count).End(xlUp).Row)
    
    Set wbPlan = Workbooks.Open(Filename:= _
         "G:\Projects\Annual Planning\2010-11\Annual Plan2010_11Combined(working copy).xlsx", UpdateLinks:=0)
        
    With wbPlan.Sheets(1)
    
        For Each cellB In rngB
    
            Set FoundB = .Cells.Find(What:=cellB.Value, LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False) 'Find each column B value in Annual Plan
                
            If Not FoundB Is Nothing Then
                .Cells(FoundB.Row, "AA").Value = wsB.Cells(cellB.Row, "D").Value
                .Cells(FoundB.Row, "AB").Value = wsB.Cells(cellB.Row, "E").Value
                .Cells(FoundB.Row, "O").Value = wsB.Cells(cellB.Row, "F").Value
                .Cells(FoundB.Row, "T").Value = wsB.Cells(cellB.Row, "O").Value
            Else
                MsgBox "Couldn't find " & cellB.Value & " in Annual Plan."
            End If
            
        Next cellB
        
    End With
    
    'wbPlan.Save
    'wbPlan.Close
    
End Sub

 

[j.millar]

That is fantastic!!

I just had to remove:

.Cells(FoundB.Row, "O").Value = wsB.Cells(cellB.Row, "F").Value

Thanks AlphaFrog!

 

[j.millar]

Is there a way to copy just the values over without the source formatting?

 

[AlphaFrog]

The macro already only copies values and not formatting.