Selected Answer
Hello akups and welcome to the forum,
Sorry for the late reply but I was a bit busy over the holidays.
I wrote a macro which I hope achieves the result you are looking for. I used your original file and copied Sheet1 a few times to use as practice sheets. Sheet1(2) is how Sheet1 looks after running the macro. Sheet1(3) and Sheet1(4) are spares that you can run the macro on to see how it works. Now that there is a macro in the file it had to be saved as an .xlsm file. The modified file is attahed.
Updated Dec. 29 - added code:
Here is the code [there are 4 nacros used]: (it might be possible that someone may be able to shorten this, but I prefer to opt for the simple/obvious rather than getting too exotic)
Sub Add_Missing_Rows_Macro()
'****************************************************************************
' macro written by WillieD24 for TeachExcel
' this macro will add row(s) for the missing data
'****************************************************************************
Dim Row1 As Long, Row2 As Long, Row3 As Long, Row4 As Long
Dim RowNum As Long
Cells(3, 1).Select
RowNum = ActiveCell.Row
Row1 = RowNum
Row2 = Row1 + 1
Row3 = Row2 + 1
Row4 = Row3 + 1
' first - check row three only (first row of list) - is Qtr1 or Qtr2 missing
Call Check_First_Entry
Do While Cells(RowNum, 1) <> "" ' while there is an "f_id " number in Col 1
RowNum = ActiveCell.Row
Row1 = RowNum - 1
Row2 = Row1 + 1
Row3 = Row2 + 1
Row4 = Row3 + 1
' has " f_id " number changed
If Cells(Row1, 1) <> Cells(Row2, 1) Then Call FID_Has_Changed
' check if Qtr1 or Qtr2 or both are missing
Call Insert_Missing_Qtrs
RowNum = ActiveCell.Row
If Cells(RowNum, 1) = "" Then Exit Sub
Loop
End Sub
Sub Check_First_Entry()
' ===================================================
' macro written by WillieD24 for TeachExcel
' this macro will add row(s) for the missing data
' ===================================================
' this is the check for row three only (first row of list)
Dim Row1 As Long ' first row of list - row 3
Dim Row2 As Long
Dim xYear As Long ' staring year - 2000
Row1 = 3
Row2 = 4
xYear = 2000
' Qtr1 is missing
If Cells(Row1, 3) = 2000 And Cells(Row1, 4) <> "Qtr1" Then
Rows((Row1) & ":" & (Row1)).Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row1, 1), Cells(Row1, 2)).Copy Range(Cells((Row2), 1), Cells((Row2), 2))
Range(Cells((Row1), 3), Cells((Row1), 5)).Interior.Color = 65535
Cells(Row1, 3) = xYear
Cells(Row1, 4) = "Qtr1"
Cells(Row2 + 1, 1).Select
End If
' Qtr2 is missing
If Cells(Row2, 3) <> "" And Cells(Row2, 4) <> "Qtr2" Then
Rows((Row2) & ":" & (Row2)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row1, 1), Cells(Row1, 2)).Copy Range(Cells((Row2), 1), Cells((Row2), 2))
Range(Cells((Row2), 3), Cells((Row2), 5)).Interior.Color = 65535
Cells(Row2, 4) = "Qtr2"
Cells(Row2 + 1, 1).Select
End If
Cells(Row2 + 1, 1).Select
End Sub
Sub FID_Has_Changed()
' ===================================================
' macro written by WillieD24 for TeachExcel
' this macro will add row(s) for the missing data
' ===================================================
Dim Row1 As Long
Dim Row2 As Long
Dim Row3 As Long
Dim Row4 As Long
Dim xYear1 As Long
Row1 = ActiveCell.Row - 2
Row2 = Row1 + 1
Row3 = Row2 + 1
Row4 = Row3 + 1
xYear1 = 2000 ' expected first year when f_id number [ col 1 ] changes
If Cells(Row2, 1) = Cells(Row3, 1) Then Exit Sub ' f_id number has not changed
' the f_id number (col A) has changed
MsgBox " '' f_id '' number has changed"
If Cells(Row3, 3) <> xYear1 Then ' year IS NOT 2000
' add missing year and Qtr1 & Qtr2
Rows(Row3 & ":" & Row4).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells((Row3 + 2), 1), Cells((Row4 + 2), 2)).Copy Range(Cells((Row3), 1), Cells((Row4), 2))
Range(Cells((Row3), 3), Cells((Row4), 5)).Interior.Color = 65535
Cells((Row3), 3) = xYear1
Cells((Row3), 4) = "Qtr1"
Cells((Row4), 4) = "Qtr2"
Cells((Row4 + 1), 1).Select
End If
If Cells(Row3, 3) = xYear1 Then ' year IS 2000
' check for missing Qtrs
If Cells(Row3, 3) = xYear1 And Cells(Row3, 4) = "Qtr1" And _
Cells(Row4, 3) = "" And Cells(Row4, 4) = "Qtr2" Then Exit Sub ' no Qtr is missing
' Qtr1 is missing
If Cells(Row3, 3) = xYear1 And Cells(Row3, 4) = "Qtr2" Then
Rows((Row3) & ":" & (Row3)).Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row4, 1), Cells(Row4, 2)).Copy Range(Cells((Row3), 1), Cells((Row3), 2))
Range(Cells(Row3, 3), Cells(Row3, 5)).Interior.Color = 65535
Cells(Row3, 3) = xYear1
Cells(Row3, 4) = "Qtr1"
Cells(Row4, 3) = ""
Cells(Row4 + 1, 1).Select
End If
' Qtr2 is missing
If Cells(Row2, 3) <> "" And Cells(Row2, 4) <> "Qtr2" Then
Rows((Row2) & ":" & (Row2)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row1, 1), Cells(Row1, 2)).Copy Range(Cells((Row2), 1), Cells((Row2), 2))
Range(Cells(Row2, 3), Cells(Row2, 5)).Interior.Color = 65535
Cells(Row2, 4) = "Qtr2"
Cells(Row3, 1).Select
End If
End If
End Sub
Sub Insert_Missing_Qtrs()
' ===================================================
' macro written by WillieD24 for TeachExcel
' this macro will add row(s) for the missing data
' ===================================================
Dim Row1 As Long
Dim Row2 As Long
Dim Row3 As Long
Dim Row4 As Long
Dim xYear1 As Long, xYear2 As Long
Row1 = ActiveCell.Row
Row2 = Row1 + 1
Row3 = Row2 + 1
Row4 = Row3 + 1
xYear1 = Cells(Row1 - 2, 3) ' year of previous entry
xYear2 = xYear1 + 1 ' expected year for this entry
' year and both Qtrs are missing
If Cells(Row1 - 1, 1) <> Cells(Row1, 1) Then xYear2 = 2000
If Cells(Row1, 3) <> xYear2 Then
Rows(Row1 & ":" & Row2).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells((Row3), 1), Cells((Row4), 2)).Copy Range(Cells((Row1), 1), Cells((Row2), 2))
Range(Cells((Row1), 3), Cells((Row2), 5)).Interior.Color = 65535
Cells((Row1), 3) = xYear2
Cells((Row1), 4) = "Qtr1"
Cells((Row2), 4) = "Qtr2"
Cells((Row3), 1).Select
End If
' year is correct and no Qtr is missing
If Cells(Row1, 3) = xYear2 And Cells(Row1, 4) = "Qtr1" And _
Cells(Row2, 3) = "" And Cells(Row2, 4) = "Qtr2" Then GoTo Skip ' no Qtr is missing
' year is correct and Qtr1 is missing
Rows((Row1) & ":" & (Row1)).Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row2, 1), Cells(Row2, 2)).Copy Range(Cells((Row1), 1), Cells((Row1), 2))
Range(Cells(Row1, 3), Cells(Row1, 5)).Interior.Color = 65535
Cells(Row1, 3) = xYear2
Cells(Row1, 4) = "Qtr1"
Cells(Row2, 4) = "Qtr2"
Cells(Row2, 3) = ""
Cells(Row3, 1).Select
If Cells(Row1, 4) = "Qtr1" And Cells(Row2, 4) = "Qtr2" Then GoTo Skip
' year is correct and Qtr2 is missing
If Cells(Row2, 3) <> "" And Cells(Row2, 4) <> "Qtr2" Then
Rows((Row2) & ":" & (Row2)).Select
Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Row1, 1), Cells(Row1, 2)).Copy Range(Cells((Row2), 1), Cells((Row2), 2))
Range(Cells(Row3, 3), Cells(Row3, 5)).Interior.Color = 65535
Cells(Row2, 4) = "Qtr2"
Cells(Row3, 1).Select
End If
Skip:
Cells(Row3, 1).Select
End Sub
Important note: The macro will run on whatever sheet is selected. If you what it to run only on a specific sheet you will need to and that bit of code.
Please don't forget to select the answer that worked for you! Just click the Select Answer button at the bottom of the desired answer.
Cheers :-)
