how insert and delete rows based on two cells values

[abdelfattah]

hello
i need help from experts . what I want add a new rows based on two cells L2,M2 .L2=NAME , M2= ROWS NUMBERS so if I write the name and the rows numbers . it should look at to COL C to match the name and insert the rows based on L2,M2 , and if the L2,M2 are empty then should delete all of empty rows for all names and if the L2= empty and the M2 is rows numbers then insert rows for all names .
note: it should insert row with the same borders and formulas
this the orginal data

MATCH.xlsm
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O
1	NAME	DEBIT	CREDIT	BALANCE								name	row
2		1,000.00	200.00	800.00
3	ITEM	DATE	NAME	INVOICE NO	NOTE	WAY OF PAID	DEBIT	CREDIT	BALANCE
4	1	8/7/2021	ALI1	INV-1000	NO PAID	-	1000		1,000.00
5	2	8/10/2021	ALI1	INV-1000	PAID	CASH		200.00	800.00
6
7
8	NAME	DEBIT	CREDIT	BALANCE
9		3,200.00	100.00	3,100.00
10	ITEM	DATE	NAME	INVOICE NO	NOTE	WAY OF PAID	DEBIT	CREDIT	BALANCE
11	1	8/8/2021	ALI2	INV-1001	NO PAID	-	2000		2,000.00
12	2	8/11/2021	ALI2	INV-1001	PAID	CASH		100.00	1,900.00
13	3	8/13/2021	ALI2	INV-1003	NO PAID	-	1200		3,100.00
14
15	NAME	DEBIT	CREDIT	BALANCE
16		3,800.00	1,000.00	2,800.00
17	ITEM	DATE	NAME	INVOICE NO	NOTE	WAY OF PAID	DEBIT	CREDIT	BALANCE
18	1	7/16/2021	ALI3	INV-1002	PAID	CASH	3000	500.00	2,500.00
19	2	7/16/2021	ALI3	INV-1002	PAID	BANK		500.00	2,000.00
20	3	7/16/2021	ALI3	INV-1004	NO PAID	-	800		2,800.00
result

Cell Formulas
Range	Formula
B2:C2	B2	=SUM(G4:G5)
D2,I18,D16,I11,D9,I4	D2	=B2-C2
I5,I19:I20,I12:I13	I5	=I4+G5-H5
B16:C16,B9:C9	B9	=SUM(G11:G13)

 

[Crystalyzer]

so the end result of entering "ALI1" in L2 and 3 in M2 should be the below?

Book1
	A	B	C	D	E	F	G	H	I	J	K	L	M
1	NAME	DEBIT	CREDIT	BALANCE								ALI1	3
2		1,000	200	800
3	ITEM	DATE	NAME	INVOICE NO	NOTE	WAY OF PAID	DEBIT	CREDIT	BALANCE
4	1	8/7/2021	ALI1	INV-1000	NO PAID	-	1,000		1,000
5	2	8/10/2021	ALI1	INV-1000	PAID	CASH		200	800
6	3		ALI1						800
7	4		ALI1						800
8	5		ALI1						800
Sheet5

Cell Formulas
Range	Formula
B2:C2	B2	=SUM(G4:G8)
D2,I4	D2	=+B2-C2
I5:I8	I5	=+I4+G5-H5

 

[abdelfattah]

yes

 

[Crystalyzer]

Ok, I have a partial solution that you can test on a copy of your workbook. This solution will ONLY do the following:

1. If L2 has a name and M2 has a number, it will insert the number of rows in M2 for the name in L2
2. If L2 does NOT have a name and M2 has a number, it will insert the number of rows for ALL names

You will need to change the formula in column I to "=SUM(G$5:G5)-SUM(H$5:H5)" for each row for every name so that the anchored row is the first row of data for the name. This is needed so that the formula can be copied in the event that a Name only has one row. It will keep the same running total that you currently calculate using a different formula in the first row than in rows 2 thru n.

Lastly can you confirm what constitutes an empty row? Can I key on the Date column and if there is no value in that column for a given row, the row is considered empty?

Sub InsDelRows()
    Dim arr As New Collection, a
    Dim n As Variant
    Dim Name As String
    Dim NoRows As Long
    Dim FstRow As Long
    Dim InsRow As Long
    Dim FstRowColC As Long
    Dim LstRowColC As Long
    
    Name = Range("L2").Value
    NoRows = Abs(Round(Range("M2").Value, 0))
        
    If Name <> "" And NoRows > 0 Then
        FstRow = WorksheetFunction.Match(Name, Range("C:C"), 0)
        If Cells(FstRow + 1, 3).Value <> Name Then
            InsRow = FstRow
        Else
            InsRow = Cells(FstRow, 3).End(xlDown).Row
        End If
        Rows(InsRow & ":" & InsRow).Copy
        Rows(InsRow & ":" & InsRow + NoRows - 1).Insert Shift:=xlDown
        Application.CutCopyMode = False
        If FstRow = InsRow Then
            Cells(InsRow + 1, 1) = 2
        End If
        Range(Cells(FstRow, 1), Cells(FstRow + 1, 1)).AutoFill Destination:=Range(Cells(FstRow, 1), Cells(InsRow + NoRows, 1))
        Range(Cells(InsRow + 1, 2), Cells(InsRow + NoRows, 2)).ClearContents
        Range(Cells(InsRow + 1, 4), Cells(InsRow + NoRows, 8)).ClearContents
    Else
        FstRowColC = WorksheetFunction.Match("Name", Range("C:C"), 0) + 1
        LstRowColC = Range("C" & Rows.Count).End(xlUp).Row
        
        On Error Resume Next
        n = Range(Cells(FstRowColC, 3), Cells(LstRowColC, 3)).Value
        For Each a In n
            If a <> "NAME" And a <> "CREDIT" Then arr.Add a, a
        Next
        On Error GoTo 0
    End If
        
    If Name = "" And NoRows > 0 Then
        For i = 1 To arr.Count
            Name = arr(i)
            FstRow = WorksheetFunction.Match(Name, Range("C:C"), 0)
            If Cells(FstRow + 1, 3).Value <> Name Then
                InsRow = FstRow
            Else
                InsRow = Cells(FstRow, 3).End(xlDown).Row
            End If
            Rows(InsRow & ":" & InsRow).Copy
            Rows(InsRow & ":" & InsRow + NoRows - 1).Insert Shift:=xlDown
            Application.CutCopyMode = False
            If FstRow = InsRow Then
                Cells(InsRow + 1, 1) = 2
            End If
            Range(Cells(FstRow, 1), Cells(FstRow + 1, 1)).AutoFill Destination:=Range(Cells(FstRow, 1), Cells(InsRow + NoRows, 1))
            Range(Cells(InsRow + 1, 2), Cells(InsRow + NoRows, 2)).ClearContents
            Range(Cells(InsRow + 1, 4), Cells(InsRow + NoRows, 8)).ClearContents
        Next
    End If
End Sub

 

[abdelfattah]

thanks for your code, but unfortunately it doesn't work at all and no error.

about the formula I can't change it when insert a new rows the formula .it should depend on last row contains the formula .about column date it's. empty

 

[Crystalyzer]

I need some more information to help understand why it isn't working for you.

1. What version of Excel do you have?
2. Where did you place the code?
3. How are you calling the code?
4. Is the sheet that it is supposed to update the active worksheet when you call the code?

As for the formula change, both formulas give the same result (see below). The difference is that mine will work when there is only one row to begin with and the formulas have to be copied down to more rows where yours would need more tweaks to get there.

Solutions 20210717 Mr Excel - abdelfattah.xlsm
	A	B	C	D	E	F	G	H	I	J
21	NAME	DEBIT	CREDIT	BALANCE
22									YOUR Fx	MY Fx
23	ITEM	DATE	NAME	INVOICE NO	NOTE	WAY OF PAID	DEBIT	CREDIT	BALANCE	BALANCE
24	1	7/16/2021	ALI3	INV-1002	PAID	CASH	3,000	500	2,500	2,500
25	2	7/16/2021	ALI3	INV-1002	PAID	BANK		500	2,000	2,000
26	3	7/16/2021	ALI3	INV-1004	NO PAID	-	800		2,800	2,800
Sheet5

Cell Formulas
Range	Formula
I24	I24	=+G24-H24
J24:J26	J24	=SUM(G$24:G24)-SUM(H$24:H24)
I25:I26	I25	=+I24+G25-H25

 

[abdelfattah]

I run in another PC .it give Unable to get the Match property of the WorksheetFunction class in this line

FstRow = WorksheetFunction.Match(Name, Range("C:C"), 0)

 

[Marc L]

Hi,​

​

you should better use Application.Match with a Variant variable and test its result with IsError or IsNumeric VBA function …​

 

[abdelfattah]

@Crystalyzer thanks the name was wrong in L2 . it was containing the space that's why I said nothing happens , but how apply condition if L2,M2 are empty then should delete empty rows from all ranges ?

 

[Crystalyzer]

I've revamped the original code so that you do not have to change your formulas. I've also completed deleting all blank rows for all ranges when L2 and M2 are empty and took @Marc L 's advice and changed the Worksheetfunction.match to Application.Match. I've inserted messaging as well to let you know when actions are taken and what they were.

Please test on a copy of your workbook.

Sub InsDelRows()
   
    Dim Name As String
    Dim InsMsg, DelMsg As String
    Dim NoRows, FstRow, InsRow, DelRow, EndDelRow As Long
   
    Name = Range("L2").Value
    NoRows = Abs(Round(Range("M2").Value, 0))
       
    'Single name inserting rows
    If Name <> "" And NoRows > 0 Then
        Call InsertRows(Name, NoRows)
        MsgBox NoRows & " rows inserted for " & Name & ",", vbOKOnly, "Information"
    End If
   
    'All names Insert blank rows
    If Name = "" And NoRows > 0 Then
        Set arr = CreateUniqueNamesArr()
        For i = 1 To arr.Count
            Name = arr(i)
            Call InsertRows(Name, NoRows)
            If InsMsg = "" Then
                InsMsg = "Inserted " & NoRows & " rows for the following names: " & vbCrLf & Name
            Else
                InsMsg = InsMsg & ", " & Name
                If i <> arr.Count Then
                    InsMsg = InsMsg & "."
                Else
                    InsMsg = InsMsg & ","
                End If
            End If
        Next
        MsgBox InsMsg, vbOKOnly, "Information"
    End If
   
    'Single name delete blank rows
    If Name <> "" And NoRows = 0 Then
        If Application.Match(Name, Range("C:C"), 0) <> 0 Then
            MsgBox DeleteBlankRows(Name), vbOKOnly, "Information"
        Else
            MsgBox Name & " not found.  No rows deleted.", vbOKOnly, "Information"
        End If
    End If
  
    'All names delete blank rows
    If Name = "" And NoRows = 0 Then
        Set arr = CreateUniqueNamesArr()
        For i = 1 To arr.Count
            Name = arr(i)
            If DelMsg = "" Then
                DelMsg = DeleteBlankRows(Name)
            Else
                DelMsg = DelMsg & vbCrLf & DeleteBlankRows(Name)
            End If
        Next
        MsgBox DelMsg, vbOKOnly, "Information"
    End If

End Sub

Private Sub InsertRows(ByVal fxName As String, ByVal fxNoRows As Long)
    Dim fxFstRow, fxInsRow As Long
   
    fxFstRow = Application.Match(fxName, Range("C:C"), 0)
    If Cells(fxFstRow + 1, 3).Value <> fxName Then
        fxInsRow = fxFstRow
    Else
        fxInsRow = Cells(fxFstRow, 3).End(xlDown).Row
    End If
   
    If fxFstRow = fxInsRow Then
        Rows(fxInsRow & ":" & fxInsRow).Copy
        Rows(fxInsRow & ":" & fxInsRow + fxNoRows - 1).Insert Shift:=xlDown
        Application.CutCopyMode = False
        Cells(fxInsRow + 1, 1) = 2
        Cells(fxInsRow - 2, 2).Formula = "=SUM(G" & fxInsRow & " : G" & fxInsRow + fxNoRows & ")"
        Cells(fxInsRow - 2, 3).Formula = "=SUM(H" & fxInsRow & " : H" & fxInsRow + fxNoRows & ")"
        Range(Cells(fxInsRow + 1, 9), Cells(fxInsRow + 1 + fxNoRows - 1, 9)).FormulaR1C1 = "=R[-1]C+RC[-2]-RC[-1]"
        Range(Cells(fxFstRow, 1), Cells(fxFstRow + 1, 1)).AutoFill Destination:=Range(Cells(fxFstRow, 1), Cells(fxInsRow + fxNoRows, 1))
        Range(Cells(fxInsRow + 1, 2), Cells(fxInsRow + fxNoRows, 2)).ClearContents
        Range(Cells(fxInsRow + 1, 4), Cells(fxInsRow + fxNoRows, 8)).ClearContents
    Else
        Rows(fxInsRow & ":" & fxInsRow).Copy
        Rows(fxInsRow & ":" & fxInsRow + fxNoRows - 1).Insert Shift:=xlDown
        Application.CutCopyMode = False
        Range(Cells(fxInsRow, 9), Cells(fxInsRow + 1 + fxNoRows - 1, 9)).FormulaR1C1 = "=R[-1]C+RC[-2]-RC[-1]"
        Range(Cells(fxFstRow, 1), Cells(fxFstRow + 1, 1)).AutoFill Destination:=Range(Cells(fxFstRow, 1), Cells(fxInsRow + fxNoRows, 1))
        Range(Cells(fxInsRow + 1, 2), Cells(fxInsRow + fxNoRows, 2)).ClearContents
        Range(Cells(fxInsRow + 1, 4), Cells(fxInsRow + fxNoRows, 8)).ClearContents
    End If
       
End Sub

Private Function CreateUniqueNamesArr() As Variant
    Dim ar As New Collection, a
    Dim n As Variant
    Dim FstRowColC, LstRowColC As Long
   
    FstRowColC = Application.Match("Name", Range("C:C"), 0) + 1
    LstRowColC = Range("C" & Rows.Count).End(xlUp).Row
   
    On Error Resume Next
    n = Range(Cells(FstRowColC, 3), Cells(LstRowColC, 3)).Value
    For Each a In n
        If a <> "NAME" And a <> "CREDIT" Then ar.Add a, a
    Next
    On Error GoTo 0
    Set CreateUniqueNamesArr = ar
End Function

Private Function DeleteBlankRows(fxName As String) As String
    Dim fxFstRow, fxDelRow, fxResult As Long
   
    fxResult = 1
   
    fxFstRow = Application.Match(fxName, Range("C:C"), 0)
    If fxFstRow <> 0 Then
        If LCase(Cells(fxFstRow + 1, 3).Value) <> LCase(fxName) Then
            fxResult = 1
        Else
            fxDelRow = Cells(fxFstRow, 3).End(xlDown).Row
            i = fxFstRow
            Do While i <= fxDelRow
                If Not IsDate(Cells(i, 2)) Then
                    Range(i & ":" & i).EntireRow.Delete
                    fxDelRow = fxDelRow - 1
                    fxResult = 0
                Else
                    i = i + 1
                End If
            Loop
        End If
    End If

    Select Case fxResult
        Case 0
            DeleteBlankRows = "All blank rows deleted for " & fxName & "."
        Case 1
            DeleteBlankRows = "No blank rows exist for " & fxName & "."
    End Select
End Function