VBA Macro

[snags]

Hi,

I am trying to add multiple blank rows to process my data quickly. I have having trouble to set a limit to the inserting of rows.

Example raw data:

Text
data
data
Text
data
Text
data
data
data
data
Text
Text

Needs to be:

Text
data
data
row
row
row
row
Text
data
row
row
row
row
row
Text (etc,etc,)

The Cell Value is ''Text'' and I would need 6 rows under cell value. There are other data under the Cell Value, these would need to stay under each Cell Value but the total rows between the Cell Values should always be 6 including the data.

I have gotten far with adding 6 rows with Resize(6).insert but this excludes the data, which then gives me more than 6 rows.

I would gladly like to know the rest of the steps.

 

[Snakehips]

@snags Try this.

Sub Ins_Rws()

Application.ScreenUpdating = False
   Set Strt = Range("A" & Rows.Count)  '<< edit column to suit
  Cells.Find(What:="Text", After:=Strt, LookIn:=xlFormulas2, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
   r = ActiveCell.Row
   fst = r
   GoTo First:
   
Do Until c = fst
   Cells.FindNext(After:=ActiveCell).Activate
    
    r = ActiveCell.Row
  
First:
    c = Cells.FindNext(After:=ActiveCell).Row
    
    Ins = 7 - c + r
    If Not Ins = 0 And Not Ins > 6 Then Cells(c, 1).Resize(Ins, 1).EntireRow.Insert
   
   Loop
Application.ScreenUpdating = True
   End Sub

Hope that helps.

 

[kevin9999]

Another option - assumes your data is in Column A and that Column B is available to use.

Option Explicit
Sub Insert6()
    Dim i As Long, j As Long, k As Long, x As Long
    Dim a, b, c, z
    Application.ScreenUpdating = False
    a = Range("A1", Cells(Rows.Count, "A").End(3))
    ReDim b(1 To UBound(a), 1 To 1)
    ReDim c(1 To UBound(a) * 7, 1 To 1)
    
    For i = 1 To UBound(a)
        If a(i, 1) = "Text" Then
            j = j + 1
        End If
        b(i, 1) = j
    Next i
    
    Range("B1").Resize(UBound(a)).Value = b
    k = Application.Max(Range("B:B"))
    
    j = 1
    For i = 1 To k
        x = 7 - Application.CountIf(Range("B:B"), i)
        For z = 1 To x
            c(j, 1) = i
            j = j + 1
        Next z
    Next i
    
    Cells(UBound(b) + 1, 2).Resize(UBound(c)).Value = c
    Range("A1", Cells(Rows.Count, "B").End(3)).Sort key1:=Range("B1"), order1:=xlAscending, Header:=xlNo
    Range("B:B").ClearContents
End Sub

Before

text rows.xlsb
	A	B
1	Text
2	data
3	data
4	Text
5	data
6	Text
7	data
8	data
9	data
10	data
11	Text
12	Text
13
Sheet1

After

text rows.xlsb
	A	B
1	Text
2	data
3	data
4
5
6
7
8	Text
9	data
10
11
12
13
14
15	Text
16	data
17	data
18	data
19	data
20
21
22	Text
23
24
25
26
27
28
29	Text
30
31
32
33
34
35
Sheet1

 

[snags]

@snags Try this.

Sub Ins_Rws()

Application.ScreenUpdating = False
   Set Strt = Range("A" & Rows.Count)  '<< edit column to suit
  Cells.Find(What:="Text", After:=Strt, LookIn:=xlFormulas2, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
   r = ActiveCell.Row
   fst = r
   GoTo First:
  
Do Until c = fst
   Cells.FindNext(After:=ActiveCell).Activate
   
    r = ActiveCell.Row
 
First:
    c = Cells.FindNext(After:=ActiveCell).Row
   
    Ins = 7 - c + r
    If Not Ins = 0 And Not Ins > 6 Then Cells(c, 1).Resize(Ins, 1).EntireRow.Insert
  
   Loop
Application.ScreenUpdating = True
   End Sub

Hope that helps.

Hi Snakehips, I have tried this code but it got rejected , code 91 something like that.

Thank you very much!

 

[snags]

Another option - assumes your data is in Column A and that Column B is available to use.

Option Explicit
Sub Insert6()
    Dim i As Long, j As Long, k As Long, x As Long
    Dim a, b, c, z
    Application.ScreenUpdating = False
    a = Range("A1", Cells(Rows.Count, "A").End(3))
    ReDim b(1 To UBound(a), 1 To 1)
    ReDim c(1 To UBound(a) * 7, 1 To 1)
   
    For i = 1 To UBound(a)
        If a(i, 1) = "Text" Then
            j = j + 1
        End If
        b(i, 1) = j
    Next i
   
    Range("B1").Resize(UBound(a)).Value = b
    k = Application.Max(Range("B:B"))
   
    j = 1
    For i = 1 To k
        x = 7 - Application.CountIf(Range("B:B"), i)
        For z = 1 To x
            c(j, 1) = i
            j = j + 1
        Next z
    Next i
   
    Cells(UBound(b) + 1, 2).Resize(UBound(c)).Value = c
    Range("A1", Cells(Rows.Count, "B").End(3)).Sort key1:=Range("B1"), order1:=xlAscending, Header:=xlNo
    Range("B:B").ClearContents
End Sub

Before

text rows.xlsb
	A	B
1	Text
2	data
3	data
4	Text
5	data
6	Text
7	data
8	data
9	data
10	data
11	Text
12	Text
13
Sheet1

After

text rows.xlsb
	A	B
1	Text
2	data
3	data
4
5
6
7
8	Text
9	data
10
11
12
13
14
15	Text
16	data
17	data
18	data
19	data
20
21
22	Text
23
24
25
26
27
28
29	Text
30
31
32
33
34
35
Sheet1

Hi Kevin9999,

Awesome, this has worked. Thank you very much!

Do you know if it is also possible for instead Text that it find a certain character in the cell? Lets say this character '' ; '' ?

 

[kevin9999]

Hi Kevin9999,

Awesome, this has worked. Thank you very much!

Do you know if it is also possible for instead Text that it find a certain character in the cell? Lets say this character '' ; '' ?

Yes, that should be possible. Test it by changing this line:

If a(i, 1) = "Text" Then

to this

If a(i, 1) Like "*;*" Then

and let me know how you go.

 

[snags]

Yes, that should be possible. Test it by changing this line:

If a(i, 1) = "Text" Then

to this

If a(i, 1) Like "*;*" Then

and let me know how you go.

Hi Kevin9999,

It worked thank very much!

 

[kevin9999]

Hi Kevin9999,

It worked thank very much!

Glad I could help and thanks for the feedback ?