Hi all! I've got code to do tedious data entry at work. The company doesn't want to change how they do it so I have a spreadsheet that will open and update a specified Excel file on a network drive.
I'd like it to work for all the rows with the same submittal# i.e. if there's 5 rows with submittal # 1.1 then the code would run through all of then before running the Calls, but stumped on how. Was thinking of a loop or a For/Next but having difficulty on how to stitch that into this:
I've had to kill Excel from the Task Manager more than once due to a errant never ending loop.
Thanks, as always, for your guidance!
I'd like it to work for all the rows with the same submittal# i.e. if there's 5 rows with submittal # 1.1 then the code would run through all of then before running the Calls, but stumped on how. Was thinking of a loop or a For/Next but having difficulty on how to stitch that into this:
VBA Code:
Sub AddResubmittalRow()
Dim FileToOpen As Variant
Dim OpenBook As Workbook
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File", FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen <> False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
End If
Dim found As Range
Set found = Sheets("OFFICE").Columns("E").Find(what:=InputBox("Enter the Submittal # to find", "Submittal #"), LookIn:=xlValues, lookAt:=xlWhole)
If found Is Nothing Then
MsgBox "Not found"
Else
found.Select
End If
ActiveCell.Offset(1, 0).EntireRow.Insert
Range("A" & ActiveCell.Row & ":J" & ActiveCell.Row).Copy
ActiveCell.Offset(1, -4).PasteSpecial xlPasteValues
ActiveCell.Offset(, 3).Resize(, 1).Value = Date
ActiveCell.Offset(, 10).Resize(, 1).Value = Date
ActiveCell.Offset(, 1).Resize(, 1).Value = ActiveCell.Offset(, 1).Resize(, 1).Value & " RESUBMITTAL"
ActiveCell.Offset(, 4).Resize(, 1).Value = ActiveCell.Offset(, 4).Resize(, 1).Value & "R"
Application.CutCopyMode = False
Application.CutCopyMode = True
Call font
Question:
GoAgain = MsgBox("Add another?", vbYesNo, "Continue?")
If GoAgain = vbYes Then
Call InsertRowAgain
GoTo Question
End If
End Sub
Sub InsertRowAgain()
Dim found As Range
Set found = Sheets("OFFICE").Columns("E").Find(what:=InputBox("Enter the Submittal # to find", "Submittal #"), LookIn:=xlValues, lookAt:=xlWhole)
If found Is Nothing Then
MsgBox "Not found"
Else
found.Select
End If
ActiveCell.Offset(1, 0).EntireRow.Insert
Range("A" & ActiveCell.Row & ":J" & ActiveCell.Row).Copy
ActiveCell.Offset(1, -4).PasteSpecial xlPasteValues
ActiveCell.Offset(, 3).Resize(, 1).Value = Date
ActiveCell.Offset(, 10).Resize(, 1).Value = Date
ActiveCell.Offset(, 1).Resize(, 1).Value = ActiveCell.Offset(, 1).Resize(, 1).Value & " RESUBMITTAL"
ActiveCell.Offset(, 4).Resize(, 1).Value = ActiveCell.Offset(, 4).Resize(, 1).Value & "R"
Application.CutCopyMode = False
Application.CutCopyMode = True
Call font
End Sub
Sub font()
'
' font Macro
'
'
Dim c As Range
Dim strFind As String
Dim firstAddress As String
strFind = "RESUBMITTAL"
With Cells
Set c = .Find(strFind, LookIn:=xlValues, lookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
c.Characters(Start:=InStr(1, c.Value, strFind), Length:=Len(strFind)).font.ColorIndex = 3
Else:
MsgBox "Not Found"
End
End If
Set c = .FindNext(c)
If Not c Is Nothing And c.Address <> firstAddress Then
Do
c.Characters(Start:=InStr(1, c.Value, strFind), Length:=Len(strFind)).font.ColorIndex = 3
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Sub
I've had to kill Excel from the Task Manager more than once due to a errant never ending loop.
Thanks, as always, for your guidance!