If the document number does not exist, a new entry will be created and added under the document-level header in the next available empty row. Below is the source code that I used.
Sub RetrieveDocumentInfo()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim searchValue As String
Dim foundCell As Range
' Define worksheets
Set wsSource = ThisWorkbook.Sheets("ACC")
Set wsTarget = ThisWorkbook.ActiveSheet
' Get the Document Number from D8
searchValue = wsTarget.Range("D8").Value
' Validate that searchValue is not empty
If searchValue = "" Then
MsgBox "Please enter a Document Number.", vbExclamation, "Missing Input"
Exit Sub
End If
' Search for the Document Number in QMS sheet column B
Set foundCell = wsSource.Columns("B").Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
' Check if the Document Number was found
If foundCell Is Nothing Then
MsgBox "Document Number not found in QMS sheet.", vbExclamation, "Not Found"
Exit Sub
End If
' Fill the corresponding cells with values from QMS sheet
With wsTarget
.Range("D9").Value = wsSource.Cells(foundCell.Row, "C").Value ' Document Name
.Range("D12").Value = wsSource.Cells(foundCell.Row, "F").Value ' Received Date
.Range("D13").Value = wsSource.Cells(foundCell.Row, "G").Value ' Effective Date
.Range("D14").Value = wsSource.Cells(foundCell.Row, "H").Value ' Originator
.Range("D15").Value = wsSource.Cells(foundCell.Row, "I").Value ' Date Last Reviewed
.Range("D16").Value = wsSource.Cells(foundCell.Row, "J").Value ' Scheduled Date of Document Review
.Range("D17").Value = wsSource.Cells(foundCell.Row, "K").Value ' Reason of Creation, Details of Change
.Range("D21").Value = wsSource.Cells(foundCell.Row, "O").Value ' Date of Deployment
.Range("D22").Value = wsSource.Cells(foundCell.Row, "P").Value ' Binder Location
.Range("D23").Value = wsSource.Cells(foundCell.Row, "Q").Value ' Status
.Range("H12").Value = wsSource.Cells(foundCell.Row, "L").Value ' Distribution List
End With
MsgBox "Data successfully retrieved!", vbInformation, "Success"
End Sub
Sub ClearFields()
Dim ws As Worksheet
' Set the target worksheet
Set ws = ThisWorkbook.ActiveSheet
' Clear the specified cells
ws.Range("D7").ClearContents ' Clear D7
ws.Range("D8").ClearContents ' Clear D8
ws.Range("D9").ClearContents ' Clear Document Name
ws.Range("D12").ClearContents ' Clear Received Date
ws.Range("D13").ClearContents ' Clear Effective Date
ws.Range("D14").ClearContents ' Clear Originator
ws.Range("D15").ClearContents ' Clear Date Last Reviewed
ws.Range("D16").ClearContents ' Clear Scheduled Date of Document Review
ws.Range("D17").MergeArea.ClearContents ' Clear the entire merged range for Reason of Creation, Details of Change
ws.Range("H12").MergeArea.ClearContents ' Clear the entire merged range for Distribution List
ws.Range("D21").ClearContents ' Clear Date of Deployment
ws.Range("D22").ClearContents ' Clear Binder Location
ws.Range("D23").ClearContents ' Clear Status
MsgBox "Fields cleared successfully!", vbInformation, "Clear Successful"
End Sub
Sub SubmitDocumentInfo()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim docNumber As String
Dim docLevel As String
Dim docLevelCode As String
Dim foundCell As Range
Dim insertRow As Long
Dim previousRow As Long
Dim docLevelRow As Long
Dim docLevelCell As Range
' Set worksheets
Set wsSource = ThisWorkbook.Sheets("QMS")
Set wsTarget = ThisWorkbook.ActiveSheet
' Get the Document Number from D8
docNumber = wsTarget.Range("D8").Value
' Get the Document Level from D7 dropdown
docLevel = wsTarget.Range("D7").Value
' Validate input
If docNumber = "" Then
MsgBox "Please enter a Document Number.", vbExclamation, "Missing Input"
Exit Sub
End If
If docLevel = "" Then
MsgBox "Please select a Document Level.", vbExclamation, "Missing Input"
Exit Sub
End If
' Extract the first string (e.g., L1, L2, etc.) from docNumber
docLevelCode = Left(docLevel, 2)
' Search for the Document Number in Column B to find its position
Set foundCell = wsSource.Columns("B").Find(What:=docNumber, LookIn:=xlValues, LookAt:=xlWhole)
' Find the Document Level row position
Set docLevelCell = wsSource.Columns("B").Find(What:=docLevel, LookIn:=xlValues, LookAt:=xlWhole)
' If the Document Level is found, get its row number
If Not docLevelCell Is Nothing Then
docLevelRow = docLevelCell.Row
Else
MsgBox "Document Level not found!", vbExclamation, "Error"
Exit Sub
End If
' If Document Number exists, insert a row above it
If Not foundCell Is Nothing Then
insertRow = foundCell.Row
' Remove the value in column A of the existing row
wsSource.Cells(insertRow, "A").Value = ""
Else
' If Document Number doesn't exist, find the next empty row after Document Level
insertRow = wsSource.Cells(docLevelRow + 1, "B").End(xlDown).Row + 1
' If next empty row is at the bottom, insert at the next available row
If insertRow > wsSource.Rows.Count Then
insertRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row + 1
End If
End If
' Insert a new row at the determined location
wsSource.Rows(insertRow).Insert Shift:=xlDown
' Populate the new row with values from the active sheet
With wsSource
.Cells(insertRow, "A").Value = docLevelCode ' Add docLevelCode to column A
.Cells(insertRow, "B").Value = docNumber ' Document Number
.Cells(insertRow, "C").Value = wsTarget.Range("D9").Value ' Document Name
.Cells(insertRow, "F").Value = wsTarget.Range("D12").Value ' Received Date
.Cells(insertRow, "G").Value = wsTarget.Range("D13").Value ' Effective Date
.Cells(insertRow, "H").Value = wsTarget.Range("D14").Value ' Originator
.Cells(insertRow, "I").Value = wsTarget.Range("D15").Value ' Date Last Reviewed
.Cells(insertRow, "J").Value = wsTarget.Range("D16").Value ' Scheduled Date of Document Review
.Cells(insertRow, "K").Value = wsTarget.Range("D17").Value ' Reason of Creation, Details of Change
.Cells(insertRow, "O").Value = wsTarget.Range("D21").Value ' Date of Deployment
.Cells(insertRow, "P").Value = wsTarget.Range("D22").Value ' Binder Location
.Cells(insertRow, "Q").Value = wsTarget.Range("D23").Value ' Status
.Cells(insertRow, "L").Value = wsTarget.Range("H12").Value ' Distribution List
End With
' Format the newly inserted row (green text, white background, no bold)
With wsSource.Rows(insertRow)
.Font.Color = RGB(0, 128, 0) ' Green text
.Interior.Color = RGB(255, 255, 255) ' White background
.Font.Bold = False ' Ensure text is not bold
.RowHeight = 50 ' Set row height to 50
'.HorizontalAlignment = xlCenter ' Center align horizontally
.VerticalAlignment = xlCenter ' Center align vertically
End With
' If Document Number exists, format the previous row and set status to "Obsolete"
If Not foundCell Is Nothing Then
previousRow = foundCell.Row
' Format the previous row as red (the row where the document number was found)
With wsSource.Rows(previousRow)
.Font.Color = RGB(255, 0, 0) ' Red text
.Interior.Color = RGB(255, 255, 255) ' White background
.Font.Bold = False ' Ensure text is not bold
.RowHeight = 20 ' Set row height to 20
' .HorizontalAlignment = xlCenter ' Center align horizontally
.VerticalAlignment = xlCenter ' Center align vertically
.Cells(1, "Q").Value = "Obsolete" ' Change Status to "Obsolete"
End With
End If
' Clear the specified cells
wsTarget.Range("D7").ClearContents ' Clear D7
wsTarget.Range("D8").ClearContents ' Clear D8
wsTarget.Range("D9").ClearContents ' Clear Document Name
wsTarget.Range("D12").ClearContents ' Clear Received Date
wsTarget.Range("D13").ClearContents ' Clear Effective Date
wsTarget.Range("D14").ClearContents ' Clear Originator
wsTarget.Range("D15").ClearContents ' Clear Date Last Reviewed
wsTarget.Range("D16").ClearContents ' Clear Scheduled Date of Document Review
wsTarget.Range("D17").MergeArea.ClearContents ' Clear the entire merged range for Reason of Creation, Details of Change
wsTarget.Range("H12").MergeArea.ClearContents ' Clear the entire merged range for Distribution List
wsTarget.Range("D21").ClearContents ' Clear Date of Deployment
wsTarget.Range("D22").ClearContents ' Clear Binder Location
wsTarget.Range("D23").ClearContents ' Clear Status
MsgBox "Document information successfully submitted!", vbInformation, "Success"
End Sub
This is the expected output that I cannot do. What can I try next?
If the document number does not exist, a new entry will be created and added under the document-level header in the next available empty row. Below is the source code that I used.
Sub RetrieveDocumentInfo()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim searchValue As String
Dim foundCell As Range
' Define worksheets
Set wsSource = ThisWorkbook.Sheets("ACC")
Set wsTarget = ThisWorkbook.ActiveSheet
' Get the Document Number from D8
searchValue = wsTarget.Range("D8").Value
' Validate that searchValue is not empty
If searchValue = "" Then
MsgBox "Please enter a Document Number.", vbExclamation, "Missing Input"
Exit Sub
End If
' Search for the Document Number in QMS sheet column B
Set foundCell = wsSource.Columns("B").Find(What:=searchValue, LookIn:=xlValues, LookAt:=xlWhole)
' Check if the Document Number was found
If foundCell Is Nothing Then
MsgBox "Document Number not found in QMS sheet.", vbExclamation, "Not Found"
Exit Sub
End If
' Fill the corresponding cells with values from QMS sheet
With wsTarget
.Range("D9").Value = wsSource.Cells(foundCell.Row, "C").Value ' Document Name
.Range("D12").Value = wsSource.Cells(foundCell.Row, "F").Value ' Received Date
.Range("D13").Value = wsSource.Cells(foundCell.Row, "G").Value ' Effective Date
.Range("D14").Value = wsSource.Cells(foundCell.Row, "H").Value ' Originator
.Range("D15").Value = wsSource.Cells(foundCell.Row, "I").Value ' Date Last Reviewed
.Range("D16").Value = wsSource.Cells(foundCell.Row, "J").Value ' Scheduled Date of Document Review
.Range("D17").Value = wsSource.Cells(foundCell.Row, "K").Value ' Reason of Creation, Details of Change
.Range("D21").Value = wsSource.Cells(foundCell.Row, "O").Value ' Date of Deployment
.Range("D22").Value = wsSource.Cells(foundCell.Row, "P").Value ' Binder Location
.Range("D23").Value = wsSource.Cells(foundCell.Row, "Q").Value ' Status
.Range("H12").Value = wsSource.Cells(foundCell.Row, "L").Value ' Distribution List
End With
MsgBox "Data successfully retrieved!", vbInformation, "Success"
End Sub
Sub ClearFields()
Dim ws As Worksheet
' Set the target worksheet
Set ws = ThisWorkbook.ActiveSheet
' Clear the specified cells
ws.Range("D7").ClearContents ' Clear D7
ws.Range("D8").ClearContents ' Clear D8
ws.Range("D9").ClearContents ' Clear Document Name
ws.Range("D12").ClearContents ' Clear Received Date
ws.Range("D13").ClearContents ' Clear Effective Date
ws.Range("D14").ClearContents ' Clear Originator
ws.Range("D15").ClearContents ' Clear Date Last Reviewed
ws.Range("D16").ClearContents ' Clear Scheduled Date of Document Review
ws.Range("D17").MergeArea.ClearContents ' Clear the entire merged range for Reason of Creation, Details of Change
ws.Range("H12").MergeArea.ClearContents ' Clear the entire merged range for Distribution List
ws.Range("D21").ClearContents ' Clear Date of Deployment
ws.Range("D22").ClearContents ' Clear Binder Location
ws.Range("D23").ClearContents ' Clear Status
MsgBox "Fields cleared successfully!", vbInformation, "Clear Successful"
End Sub
Sub SubmitDocumentInfo()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim docNumber As String
Dim docLevel As String
Dim docLevelCode As String
Dim foundCell As Range
Dim insertRow As Long
Dim previousRow As Long
Dim docLevelRow As Long
Dim docLevelCell As Range
' Set worksheets
Set wsSource = ThisWorkbook.Sheets("QMS")
Set wsTarget = ThisWorkbook.ActiveSheet
' Get the Document Number from D8
docNumber = wsTarget.Range("D8").Value
' Get the Document Level from D7 dropdown
docLevel = wsTarget.Range("D7").Value
' Validate input
If docNumber = "" Then
MsgBox "Please enter a Document Number.", vbExclamation, "Missing Input"
Exit Sub
End If
If docLevel = "" Then
MsgBox "Please select a Document Level.", vbExclamation, "Missing Input"
Exit Sub
End If
' Extract the first string (e.g., L1, L2, etc.) from docNumber
docLevelCode = Left(docLevel, 2)
' Search for the Document Number in Column B to find its position
Set foundCell = wsSource.Columns("B").Find(What:=docNumber, LookIn:=xlValues, LookAt:=xlWhole)
' Find the Document Level row position
Set docLevelCell = wsSource.Columns("B").Find(What:=docLevel, LookIn:=xlValues, LookAt:=xlWhole)
' If the Document Level is found, get its row number
If Not docLevelCell Is Nothing Then
docLevelRow = docLevelCell.Row
Else
MsgBox "Document Level not found!", vbExclamation, "Error"
Exit Sub
End If
' If Document Number exists, insert a row above it
If Not foundCell Is Nothing Then
insertRow = foundCell.Row
' Remove the value in column A of the existing row
wsSource.Cells(insertRow, "A").Value = ""
Else
' If Document Number doesn't exist, find the next empty row after Document Level
insertRow = wsSource.Cells(docLevelRow + 1, "B").End(xlDown).Row + 1
' If next empty row is at the bottom, insert at the next available row
If insertRow > wsSource.Rows.Count Then
insertRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row + 1
End If
End If
' Insert a new row at the determined location
wsSource.Rows(insertRow).Insert Shift:=xlDown
' Populate the new row with values from the active sheet
With wsSource
.Cells(insertRow, "A").Value = docLevelCode ' Add docLevelCode to column A
.Cells(insertRow, "B").Value = docNumber ' Document Number
.Cells(insertRow, "C").Value = wsTarget.Range("D9").Value ' Document Name
.Cells(insertRow, "F").Value = wsTarget.Range("D12").Value ' Received Date
.Cells(insertRow, "G").Value = wsTarget.Range("D13").Value ' Effective Date
.Cells(insertRow, "H").Value = wsTarget.Range("D14").Value ' Originator
.Cells(insertRow, "I").Value = wsTarget.Range("D15").Value ' Date Last Reviewed
.Cells(insertRow, "J").Value = wsTarget.Range("D16").Value ' Scheduled Date of Document Review
.Cells(insertRow, "K").Value = wsTarget.Range("D17").Value ' Reason of Creation, Details of Change
.Cells(insertRow, "O").Value = wsTarget.Range("D21").Value ' Date of Deployment
.Cells(insertRow, "P").Value = wsTarget.Range("D22").Value ' Binder Location
.Cells(insertRow, "Q").Value = wsTarget.Range("D23").Value ' Status
.Cells(insertRow, "L").Value = wsTarget.Range("H12").Value ' Distribution List
End With
' Format the newly inserted row (green text, white background, no bold)
With wsSource.Rows(insertRow)
.Font.Color = RGB(0, 128, 0) ' Green text
.Interior.Color = RGB(255, 255, 255) ' White background
.Font.Bold = False ' Ensure text is not bold
.RowHeight = 50 ' Set row height to 50
'.HorizontalAlignment = xlCenter ' Center align horizontally
.VerticalAlignment = xlCenter ' Center align vertically
End With
' If Document Number exists, format the previous row and set status to "Obsolete"
If Not foundCell Is Nothing Then
previousRow = foundCell.Row
' Format the previous row as red (the row where the document number was found)
With wsSource.Rows(previousRow)
.Font.Color = RGB(255, 0, 0) ' Red text
.Interior.Color = RGB(255, 255, 255) ' White background
.Font.Bold = False ' Ensure text is not bold
.RowHeight = 20 ' Set row height to 20
' .HorizontalAlignment = xlCenter ' Center align horizontally
.VerticalAlignment = xlCenter ' Center align vertically
.Cells(1, "Q").Value = "Obsolete" ' Change Status to "Obsolete"
End With
End If
' Clear the specified cells
wsTarget.Range("D7").ClearContents ' Clear D7
wsTarget.Range("D8").ClearContents ' Clear D8
wsTarget.Range("D9").ClearContents ' Clear Document Name
wsTarget.Range("D12").ClearContents ' Clear Received Date
wsTarget.Range("D13").ClearContents ' Clear Effective Date
wsTarget.Range("D14").ClearContents ' Clear Originator
wsTarget.Range("D15").ClearContents ' Clear Date Last Reviewed
wsTarget.Range("D16").ClearContents ' Clear Scheduled Date of Document Review
wsTarget.Range("D17").MergeArea.ClearContents ' Clear the entire merged range for Reason of Creation, Details of Change
wsTarget.Range("H12").MergeArea.ClearContents ' Clear the entire merged range for Distribution List
wsTarget.Range("D21").ClearContents ' Clear Date of Deployment
wsTarget.Range("D22").ClearContents ' Clear Binder Location
wsTarget.Range("D23").ClearContents ' Clear Status
MsgBox "Document information successfully submitted!", vbInformation, "Success"
End Sub
This is the expected output that I cannot do. What can I try next?
For the second data entry, the document number does not exist in Col B, then the code locates the last used cell from the bottom of column B. However, the title row of L6 (cell B310) is located below L5. This causes the script to insert the second data entry in the wrong location (row 311).
' If Document Number doesn't exist, find the next empty row after Document Level
insertRow = wsSource.Cells(docLevelRow + 1, "B").End(xlDown).Row + 1
Changes in SubmitDocumentInfo()
Note: The revised code passes the VBA compilation successfully, but it has not yet been tested.
' If Document Number exists, insert a row above it
If Not foundCell Is Nothing Then
insertRow = foundCell.Row
' Remove the value in column A of the existing row
wsSource.Cells(insertRow, "A").Value = ""
' Insert a new row above it
wsSource.Rows(insertRow).Insert Shift:=xlDown
Else
Dim iRow As Long, sValB As String
iRow = docLevelRow + 1
Do While True
sValB = wsSource.Cells(iRow, "B")
If Len(sValB) = 0 Then ' blank row
insertRow = iRow
Exit Do
ElseIf sValB Like "L*Document" Then
' assuming all levels' title on Col B are in the same format: "L[digits] ... Document"
' Found the next doc level title (eg L6)
' It means L5' cells are full(eg. B298:B398 is full for L5)
' Insert a new row at the end
wsSource.Rows(iRow).Insert Shift:=xlDown
insertRow = iRow
Exit Do
End If
iRow = iRow + 1
If iRow > wsSource.Rows.Count Then
MsgBox "Can't find the blank row.", vbExclamation, "Not Found"
Exit Sub
End If
Loop
' ' If Document Number doesn't exist, find the next empty row after Document Level
' insertRow = wsSource.Cells(docLevelRow + 1, "B").End(xlDown).Row + 1
' ' If next empty row is at the bottom, insert at the next available row
' If insertRow > wsSource.Rows.Count Then
' insertRow = wsSource.Cells(wsSource.Rows.Count, "B").End(xlUp).Row + 1
' End If
End If