2

Would anyone will be able to help me with this script please?

As it stand, this current macro separate the data once the value/text have changes and insert new row but I just cannot work it out how to include the headers once the row have been inserted.

Sub Insert Row()

Dim ws As Worksheet
Dim lr As Long
Dim i As Long

Set ws = Worksheets("Sheet1") 'the sheet with the data
lr = ws.Range("A" & Rows.Count).End(xlUp).Row 'last row with data in Column A
For i = lr - 1 To 2 Step -1
If ws.Range("A" & i).Value <> ws.Range("A" & i + 1).Value Then ws.Range("A" & i + 1).EntireRow.Insert
Next i

End Sub

enter image description here

Thank you in advanced.

TK4795
  • 61
  • 9
  • Take a look at [this](https://stackoverflow.com/a/74987395). To get the gap (empty row), duplicate `durg.EntireRow.Insert xlShiftDown` in the final If statement. If the 2nd column is the one you're splitting the data in, use `drg.Columns(2).Cells`. – VBasic2008 Jan 16 '23 at 08:01
  • 3
    Off topic formula solution: `=DROP(DROP(REDUCE(0,ROW(A2:C3),LAMBDA(x,y,VSTACK(x,A1:C1,INDEX(A:C,y,),{"","",""}))),1,),-1)` – P.b Jan 16 '23 at 08:03
  • @VBasic2008 that doesn't work for me as I have multiple worksheets :( – TK4795 Jan 16 '23 at 08:08
  • What's that supposed to mean? Your code works on a single worksheet. – VBasic2008 Jan 16 '23 at 08:12
  • @P.b: Great stuff. If someone uses semicolons instead of commas, the array needs to stay with commas i.e. {"","",""}. – VBasic2008 Jan 16 '23 at 08:21
  • My apologies, it doesn't pick up the code at all. It's not even sort the data for me. – TK4795 Jan 16 '23 at 08:22
  • If the code is in another workbook (e.g. `PERSONAL.xlsb`) than the one containing your `Sheet1`, then you need to use `ActiveWorkbook` instead of `ThisWorkbook`. – VBasic2008 Jan 16 '23 at 08:27
  • If I understand you correctly .... `With ActiveSheet: Set rgHdr = .Range("A1", .Range("A1").End(xlToRight)): Set rgData = .Range("A2", .Range("C" & Rows.Count).End(xlUp)): Set oFill = rgData.End(xlDown).Offset(6, 0): End With` .... `For i = 1 To rgData.Rows.Count: Union(rgHdr, rgData.Rows(i)).Copy: oFill.PasteSpecial (xlAll): Set oFill = oFill.Offset(3, 0): Next i`. rgHdr is the range of the header, rgData is the Data in column A to C start from row 2, oFill is the cell to begin the separation. It loop as many rows in rgData, copy the union of rgHdr & the looped row of rgData, paste to oFill. – karma Jan 16 '23 at 08:49
  • @VBasic2008: regarding the formula: on a German system (using semicolons) you need to put dots (.) to create a vertical array (`{""."".""}`) – Ike Jan 16 '23 at 08:55
  • I have tried this on just a single worksheet, it still doesn't read the code and nothing happened. – TK4795 Jan 16 '23 at 08:58
  • 3
    To avoid system language array notation errors: `=DROP(DROP(IFERROR(REDUCE(0,ROW(A2:C3),LAMBDA(x,y,VSTACK(x,A1:C1,INDEX(A:C,y,),""))),""),1),-1)` – P.b Jan 16 '23 at 08:58
  • @TK4795 the function above is not VBA code, but a worksheet function. Just paste the formula in a cell and it works. You do need Office 365 for this. – P.b Jan 16 '23 at 09:03
  • The code I previously shown, work absolutely fine, I just wanted to be able to add a header. – TK4795 Jan 16 '23 at 09:17
  • @Ike: A horizontal array is needed so I am assuming that you meant a horizontal array. I had changed my decimal separator to a dot to test something, so the array separator became a comma. Now that I've changed it back, the backslash (`\\`) has become my 'horizontal' separator. Sorry for the misinformation. Could you share if the backslash also works on your german configuration (I'm asking because I read somewhere that there is something like a spare separator). BTW, the dot doesn't work on my system (croatian). Thx. – VBasic2008 Jan 16 '23 at 09:33
  • 1
    @VBasic2008: sorry, I meant a horizontal array. For the German configuration only a dot (.) works - backslash throws an error (as with a comma (,). For a vertical array we have to use a semicolon (;). – Ike Jan 16 '23 at 09:49
  • Is there a code that can be added to my current one at all? I just wanted to add a header. Thank you in advanced. – TK4795 Jan 16 '23 at 10:27

2 Answers2

2

Duplicate Headers

A Quick Fix

Sub InsertHeaders()

    Const FIRST_ROW As Long = 1
    Const EMPTY_ROWS As Long = 1
    
    Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
    Dim LastRow As Long: LastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    Dim r As Long
    
    For r = LastRow To FIRST_ROW + 2 Step -1
        With ws.Cells(r, "A")
            If .Value <> .Offset(-1).Value Then
                .EntireRow.Resize(EMPTY_ROWS + 1).Insert
                ws.Rows(1).Copy ws.Rows(.Row - 1)
            End If
        End With
    Next r

End Sub
VBasic2008
  • 44,888
  • 5
  • 17
  • 28
0

Please ignore my comment, as I just realize that it will be a different result if in column A there is a cell with the same value.

Example Data :
enter image description here

Expected result after running the sub :
enter image description here

Sub test()
Dim rgHdr As Range: Dim rgData As Range: Dim cell As Range
Dim i As Integer: Dim arr: Dim ins As Integer:dim sh as worksheet

Set sh = Sheets("Sheet1") 'change if needed
ins = 3 'change if needed

With sh
    .Range("A1").EntireRow.Resize(ins).Insert Shift:=xlDown
    Set rgHdr = .Range("A1").EntireRow.Resize(1 + ins)
    Set rgData = .Range("K" & 2 + ins, .Range("K" & Rows.Count).End(xlUp))
End With

Set arr = CreateObject("scripting.dictionary")
For Each cell In rgData: arr.Item(cell.Value) = 1: Next

For i = 1 To arr.Count - 1
    rgHdr.Copy
    sh.Cells(rgData.Find(arr.Keys()(i), _
      after:=rgData.End(xlDown)).Row, 1).Insert Shift:=xlDown
Next
    
sh.Range("A1").EntireRow.Resize(ins).Delete
End Sub

sh = the sheets where the data is.
ins = skip how many blank rows.

The code use "insert copied cells" method, so it make three blank rows (the value of ins) before the header, then set the first three rows as rgHdr, set the rgData from K2 down to the last row with value.

arr = unique value in column K.

then it loop to each element in arr, get the first row occurence of the found cell which value is the looped element in arr, insert the copied rgHdr to that row.

Then finally it delete those three (ins value is 3) additional blank rows.

karma
  • 1,999
  • 1
  • 10
  • 14
  • Thank you so much, the code works but it doesn't includes all the information in other cell, I have to change the range to K as my column A is a blank as I still need them for later data. The code doesn't delete the previous data, it just putting the information underneath it? Thank you for your help. – TK4795 Jan 16 '23 at 09:45
  • @TK4795, Sorry, in your image I see that your data is across 3 columns and start from cell A2. So the code follow the data based on the kind of data and the expected result just like in your image attachment. Please have a look to the updated code which this time it will retain all of columns value because it use the whole row value (doesn't care with the column). – karma Jan 16 '23 at 15:45