Thanks for the help Hans & I do really appreciate it.
By the way here is the full code I'm having.
Code: Select all
Sub Save()
On Error Resume Next
Application.ScreenUpdating = False
Dim r As Long
Dim m As Long
Dim n As Long
Dim DataDetailsWks As Worksheet
Dim DataWks As Worksheet
Dim DischargesWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
'cells to copy from Data sheet - some contain formulas
myCopy = "N5,N66,N7,I12,M16,I19,M19,I21,I23,I39,I66,J68,M68"
Set DataWks = Worksheets("Data")
Set DataDetailsWks = Worksheets("DataDetails")
Set DischargesWks = Worksheets("Discharges")
With DataWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the fields!", vbExclamation
Exit Sub
End If
End With
m = DataWks.Range("I" & DataWks.Rows.Count).End(xlUp).Row
' Headers are now in row 4
If m = 24 Then
MsgBox "Please fill in all the fields!", vbExclamation
Exit Sub
End If
r = DischargesWks.Range("C" & DischargesWks.Rows.Count).End(xlUp).Row + 1
' Copy column I
DataWks.Range("I25:I33").Copy Destination:=DischargesWks.Range("C" & r)
' Copy Findings from Column K
DataWks.Range("K25:K33").Copy Destination:=DischargesWks.Range("D" & r)
' Copy Column I
DataWks.Range("I45:I53").Copy Destination:=DischargesWks.Range("E" & r)
' Copy column K
DataWks.Range("K45:K53").Copy Destination:=DischargesWks.Range("F" & r)
' Copy column I
DataWks.Range("I55:I63").Copy Destination:=DischargesWks.Range("G" & r)
' Copy column K
DataWks.Range("K55:K63").Copy Destination:=DischargesWks.Range("H" & r)
' Copy Serial number
DataWks.Range("N5").Copy Destination:=DischargesWks.Range("B" & r & ":B" & m)
' Copy Date
DischargesWks.Range("A" & r & ":A" & m) = DataWks.Range("N66")
DischargesWks.Range("A5:H5").Copy
DischargesWks.Range("A" & r & ":H").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
With DataDetailsWks
nextRow = .Cells(.Rows.Count, "C").End(xlUp).Offset(1, 0).Row
End With
With DataDetailsWks
With .Cells(nextRow, "C")
.Value = Now
.NumberFormat = "hh:mm:ss"
End With
oCol = 4
For Each myCell In myRng.Cells
DataDetailsWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
With DataWks.Range("N5")
.Value = .Value + 1
End With
DataWks.Range("I25:I33,K25:K33, I12, M16, I19, M19, I21, I23, I39, I66, K68, M68").ClearContents
'clear input cells that contain constants
With DataWks
On Error Resume Next
With .Range("I12,M16,I19,M19,I21,I23,I39,I66,K68,M68").Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
Application.ScreenUpdating = True
End Sub
The rest of the code works fine except the part;
Code: Select all
' Copy Serial number
DataWks.Range("N5").Copy Destination:=DischargesWks.Range("B" & r & ":B" & m)
' Copy Date
DischargesWks.Range("A" & r & ":A" & m) = DataWks.Range("N66")
Meaning the date and serial number does not get copied to the starting from the first empty row in column A & B and down to the last data row in the excel DischargesWks.
I would be happy if you could figure out a way to do this.
Thanks in advance.