When using the following code it copies the data as mentioned in the code from the “Orders†sheet to “PatDetails†& “Databaseâ€. But it copies extra five rows within the columns A to E to the sheet "Database" each time I run the macro .
What might I have done wrong in coding that is causing the problem.
I would be happy if you could explain me what I have done wrong in here.
Code: Select all
Sub SaveData()
On Error Resume Next
Application.ScreenUpdating = False
Dim r As Long
Dim m As Long
Dim t As Long
Dim strCategory As String
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Set wshSource = Worksheets("Orders")
Set wshTarget = Worksheets("Database")
Dim n As Long
Dim PatDetailsWks As Worksheet
Dim OrdersWks As Worksheet
Dim DatabaseWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
' Determine the last used row
' in column F on the Database sheet
With wshTarget
t = .Cells(.Rows.Count, 6).End(xlUp).Row
End With
With wshSource
' Determine last used row in column A
' on the Orders sheet
m = .Cells(.Rows.Count, 1).End(xlUp).Row
For r = 14 To m
If .Cells(r, 1) = "" Then
If .Cells(r, 2) <> "" Then
strCategory = .Cells(r, 2)
End If
ElseIf .Cells(r, 1) <> "Test Name" Then
t = t + 1
wshTarget.Cells(t, 6) = strCategory
.Range(.Cells(r, 1), .Cells(r, 4)).Copy
wshTarget.Cells(t, 7).PasteSpecial Paste:=xlPasteValues
End If
Next r
End With
'cells to copy from Orders sheet - some contain formulas
myCopy = "B9,F9,F10,F11,F12,F13,F14,H9,H10,H11,H12,H13,H14"
Set OrdersWks = Worksheets("Orders")
Set PatDetailsWks = Worksheets("PatDetails")
Set DatabaseWks = Worksheets("Database")
With OrdersWks
Set myRng = .Range(myCopy)
If Application.CountA(myRng) <> myRng.Cells.Count Then
MsgBox "Please fill in all the fields!"
Exit Sub
End If
End With
r = DatabaseWks.Range("A" & DatabaseWks.Rows.Count).End(xlUp).Row + 1
' Copy Date Collected
OrdersWks.Range("H12").Copy Destination:=DatabaseWks.Range("B" & r & ":B" & (r + m - 16))
' Copy Accession No
OrdersWks.Range("H9").Copy Destination:=DatabaseWks.Range("E" & r & ":E" & (r + m - 16))
' Copy Customer ID
OrdersWks.Range("B9").Copy Destination:=DatabaseWks.Range("C" & r & ":C" & (r + m - 16))
' Copy CL
OrdersWks.Range("F9").Copy Destination:=DatabaseWks.Range("D" & r & ":D" & (r + m - 16))
' Time Collected
OrdersWks.Range("H11").Copy Destination:=DatabaseWks.Range("A" & r & ":A" & (r + m - 16))
DatabaseWks.Range("A10:E10").Copy
DatabaseWks.Range("A" & r & ":E" & (r + m - 16)).PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
With PatDetailsWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With PatDetailsWks
With .Cells(nextRow, "A")
.Value = Now
.NumberFormat = "hh:mm:ss"
End With
oCol = 2
For Each myCell In myRng.Cells
PatDetailsWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
With OrdersWks.Range("H9")
.Value = .Value + 1
End With
ThisWorkbook.Save
Application.ScreenUpdating = True
End Sub
