Random rows being overwritten on 'data store' workbook after copying from input workbook

Originally Posted by BadlySpelledBuoy

Any chance we could see a desensitized version of the workbook?
Makes these issues far easier to diagnose.

BSB

Unfortunately due to the nature of the document, the whole main page is sensitive and would require basically deleting. I think the main issue is with our second module, used to click submit on the main sheet which then copies all the data to the database.

The module 2 code I can share, which is

Function IsFileOpen(FileName As String)
Dim iFilenum As Long
Dim iErr As Long

On Error Resume Next
iFilenum = FreeFile()
Open FileName For Input Lock Read As #iFilenum
Close iFilenum
iErr = Err
On Error GoTo 0

Select Case iErr
Case 0: IsFileOpen = False
Case 70: IsFileOpen = True
Case Else: Error iErr
End Select

End Function


Sub submit()

Application.ScreenUpdating = False

If Not IsFileOpen("file path QA Database.xls") Then
Workbooks.Open "file path QA Database.xls"
End If


Workbooks("QA Database.xls").Activate
Workbooks("QA Database.xls").Worksheets("Database").Select

ActiveSheet.Unprotect ("password goes here")

Windows("QA.xls").Activate

ActiveSheet.Unprotect ("password here")
If MsgBox("Choose OK to submit these results to the database. Please 'RESET' the form before resubmitting another check. If this form says changes have been made to the Database, select keep changes and then resubmit", vbOKCancel) = vbOK Then
Application.EnableEvents = False

If Range("Z17").Value = "1" Then
MsgBox "Data already copied to QA log"
Exit Sub
End If

Range("Z17") = 0

If Range("B4").Value = "" Then
MsgBox "Please Enter Case owner name"
Exit Sub
End If

If Range("B5").Value = "" Then
MsgBox "Please Enter reference"
Exit Sub
End If

If Range("B6").Value = "" Then
MsgBox "Please Enter Outcome Date"
Exit Sub
End If

If Range("D4").Value = "" Then
MsgBox "Please Enter your name"
Exit Sub
End If

If Range("C9").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If


If Range("C10").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C11").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C12").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C13").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C14").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C15").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C16").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C17").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C18").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C19").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C20").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C21").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If

If Range("C22").Value = "" Then
MsgBox "Cells cannot be left blank, please select N/A"
Exit Sub

End If




Range("B4").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("C" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues


Windows("QA.xls").Activate
Range("B5").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("E" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("B7").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BC" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("D4").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BA" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("D5").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("D" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("B6").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("D6").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("BB" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues


Windows("QA.xls").Activate
Range("A3").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("F" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C9").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C10").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("I" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C11").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("J" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C12").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("K" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C13").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("L" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C14").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("M" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C15").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("N" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C16").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("O" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C17").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("P" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C18").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("Q" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C19").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("R" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C20").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("S" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C21").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("T" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues

Windows("QA.xls").Activate
Range("C22").Select
Selection.Copy
Windows("QA Database.xls").Activate
Range("U" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues



Windows("QA.xls").Activate
ChDir "File path"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:="file path" & Range("B4").Value & Range("J5").Value & Range("B5").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Windows("QA Database.xls").Activate

ActiveWorkbook.Save
ActiveWorkbook.Close

MsgBox "Your scores have been successfully submitted!"

Application.EnableEvents = True
Else
Exit Sub
End If



End Sub

Sub SavePDF()
'
' SavePDF Macro
'

'
ChDir "file path"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=Range("B4").Value _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=True
End Sub

Column C from C9 down is the scoring input cell. The first lot of code makes it error on blank and the second lot copies it to the database.

The other cells it asks to copy are random other bits of information. I've had to delete a few repeated codes to fit into the letter limit for the forum