Macro for Opening and copying data to another workbook with password

**Robotacha2010** · 01-04-2010, 05:10 PM

Hello,

I was wondering if someone could help me / give advice on a macro I need.

I'm guessing what I want to achieve should be quite simple.

I have a blank form (workbook1). Sales fill in the form, and email it to me for logging and circulation.

I then manually input the data onto a spreadsheet (workbook2) and email company wide. I want to slowly automate this whole process or at least make it easier for me as Im getting about 20 - 30 of these forms aday.

So,

I have workbook 1.
Cells E13 , B7, D19 & B2 have the information I want to copy.

Workbook 2 is password protected.
I want to copy the above data to this workbook into column A, B, C & D all on the same row.

Save.

Then when I run the macro again, say the next day on a new / different workbook, I want to copy to workbook 2 again, but in the next empty row.

The macro will be a button which is embedded in the blank template (workbook1)

Can anyone help?

Help much appreciated!

Thanks

Michael

**davesexcel** · 01-04-2010, 09:34 PM

Try this out, make sure the WorkBook is in a folder that matches the code.

OriginalWorkBook is the workbook that has the data to send to the GetNewData workbook.

I have tested it many times and have not received an error.

Sub SendNewData()

    Dim wb1 As Workbook, wb2 As Workbook, ws1 As Worksheet, ws2 As Worksheet, rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range

    Set wb1 = Workbooks("GetNewData.xls")
    Set wb2 = Workbooks("OriginalWorkBook.xls")
    Set ws1 = wb1.Worksheets("Sheet1")
    Set ws2 = wb2.Worksheets("Sheet1")
    Set rng1 = ws1.Range("A65536").End(xlUp).Offset(1, 0)
    Set rng2 = ws1.Range("B65536").End(xlUp).Offset(1, 0)
    Set rng3 = ws1.Range("C65536").End(xlUp).Offset(1, 0)
    Set rng4 = ws1.Range("D65536").End(xlUp).Offset(1, 0)


    Application.DisplayAlerts = False

    rng1 = ws2.Range("E13")
    rng2 = ws2.Range("B7")
    rng3 = ws2.Range("D19")
    rng4 = ws2.Range("B2")

End Sub
Sub OpenBook()

    Dim wb1 As Workbook

    On Error Resume Next

    Set wb1 = Workbooks("GetNewData.xls")

    If wb1 Is Nothing Then    'Not open
        Workbooks.Open Filename:="C:\Excel\GetNewData.xls"    ' change this to your folder
        SendNewData
        ActiveWorkbook.Close savechanges:=True

        On Error GoTo 0
    Else:    'is open
        With wb1
            SendNewData
            .Close savechanges:=True
        End With
    End If

End Sub

**Leith Ross** · 01-04-2010, 11:03 PM

Hello Michael,

This is a little different than Dave's. This macro uses the Open Dialog to let you pick the Excel file to open. The sheet copied to is "Sheet1" you can change this to match you sheet name. Currently, the sheet is protected without a password. You can add one to the variable PWD. Both are marked in blue.

Sub UpdateFile()
  
  Dim Data(1 To 4) As Variant
  Dim DstRng As Range
  Dim DstWks As Worksheet
  Dim FileFilter As String
  Dim I As Long
  Dim LastRow As Long
  Dim PWD As String
  Dim SrcRng As Range
  Dim SrcWkb As Variant
  
    FileFilter = "All Excel Workbooks (*.xl*),*.xl*"
    SrcWkb = Application.GetOpenFilename(FileFilter)
    
    If SrcWkb = False Then Exit Sub
    Set SrcWkb = Workbooks.Open(SrcWkb)
    
    Set SrcRng = SrcWkb.Worksheets(1).Range("B2,B7,D19,E13")
    
    Set DstWks = ThisWorkbook.Worksheets("Sheet1")
    PWD = ""
    DstWks.Unprotect PWD
    
    LastRow = DstWks.Cells(Rows.Count, "A").End(xlUp).Row
    Set DstRng = DstWks.Cells(LastRow + 1, "A").Resize(Columnsize:=4)
    
      For Each Cell In SrcRng
        I = I + 1
        Data(I) = Cell.Value
      Next Cell
    
      DstRng.Value = Data
      
    DstWks.Protect PWD
    SrcWkb.Close False
    
End Sub