CODEWITHSUNDEEP
excelvba
nadz
nadz

Reputation: 47

EXCEL Save data into different workbook - VBA

Good day,

I have a sheet that requests a user to enter data and then click a button to save the data into the database. The database is currently located in the same workbook "Different worksheet".

What i basically need is for this data to be saved on a different worksheet that i call "Consolidated.xlsx" which is available in a different folder "C:/reports/consolidates.xlsx" so that only I can access this data and no one else

Please let me know if you can help

Document currently available under the following link: www.dropbox.com/s/3wea245lmek8hef/FormSheet.xls

Thanks

Upvotes: 1

Views: 15222

Answers (1)

Dan Wagner
Dan Wagner

Reputation: 2713

EDIT 4/19: the code below has been updated to write to the local "PartsData" sheet as well as the consolidated target... You still need to make sure there is a sheet on your "consolidated" file that is named "PartsData":

Option Explicit
Sub UpdateLogWorksheet()

Dim historyWks As Worksheet, localWks As Worksheet, _
    inputWks As Worksheet, indexWks As Worksheet
Dim historyWb As Workbook
Dim MyWorksheets As New Collection
Dim nextRow As Long, oCol As Long
Dim myRng As Range, myCell As Range
Dim myCopy As String

'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"

'assign variables for easy reference
Set inputWks = ThisWorkbook.Worksheets("Input")
Set localWks = ThisWorkbook.Worksheets("PartsData")
Set historyWb = Workbooks.Open("C:\reports\consolidated.xlsx")
Set historyWks = historyWb.Worksheets("PartsData")

'put both target worksheets into a collection for an easy loop
MyWorksheets.Add Item:=localWks
MyWorksheets.Add Item:=historyWks

With historyWks
    nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With

With inputWks
    Set myRng = .Range(myCopy)
    If Application.CountA(myRng) <> myRng.Cells.Count Then
        MsgBox "Please fill in all the cells!"
        Exit Sub
    End If
End With

'write results of form to both local parts data and consolidated parts data
For Each indexWks In MyWorksheets
    With indexWks
        With .Cells(nextRow, "A")
            .Value = Now
            .NumberFormat = "mm/dd/yyyy hh:mm:ss"
        End With
        .Cells(nextRow, "B").Value = Application.UserName
        oCol = 3
        For Each myCell In myRng.Cells
            indexWks.Cells(nextRow, oCol).Value = myCell.Value
            oCol = oCol + 1
        Next myCell
    End With
Next indexWks

historyWb.Save '<~ save and close the target workbook
historyWb.Close SaveChanges:=False

'clear input cells that contain constants
With inputWks
  On Error Resume Next
     With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
          .ClearContents
          Application.GoTo .Cells(1) ', Scroll:=True
     End With
  On Error GoTo 0
End With
End Sub

Upvotes: 3

Related Questions