nadz84
04-18-2014, 01:07 AM
I have the below code for an excel form to currently save data in another excel.the only issue is that this doesn't work properly if more than 1 person are trying to send the data. Is it possible to make the code in a way that it sends data to an access db? Here my code.
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim historyWb As Workbook '<~ target workbook
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
Set inputWks = Worksheets("Input")
Set historyWb = Workbooks.Open("C:\reports\consolidated.xlsx") '<~ open target workbook and assign sheet
Set historyWks = historyWb.Worksheets("PartsData")
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
With historyWks
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
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
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
Sub UpdateLogWorksheet()
Dim historyWks As Worksheet
Dim inputWks As Worksheet
Dim historyWb As Workbook '<~ target workbook
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "D5,D7,D9,D11,D13"
Set inputWks = Worksheets("Input")
Set historyWb = Workbooks.Open("C:\reports\consolidated.xlsx") '<~ open target workbook and assign sheet
Set historyWks = historyWb.Worksheets("PartsData")
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
With historyWks
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
historyWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
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