I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub
Related
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
My ultimate goal is to read a range from one workbook and input it into specific cells in another workbook. The source Workbook has a range of autofiltered data in columns A-D. The destination workbook has 8 fields that need to be filled and they will always be the same. For instance, The source workbook will have the first field of the Array MyArray(x) go into the field B2 on the destination workbook. Then MyArray(x) will have x=2 which will populate D2 in the destination workbook from the next visible row in column B. So, it would look like this:
Source workbook
A
B
C
D
1
User Name
AccountNo
Last3
Software to Load
3
User 2
10161_4002
MM1
License E3
4
User 3
10202_2179
118
6
User 5
10141_9863
AA5
License-E3,Reflection
7
User 6
10167_3006
B35
RSI,Java
9
User 8
10176_3393
W45
Office365,Java
And the destination workbook would look like this:
A
B
C
D
1
2
Name:
Account Number:
3
ID:
Software:
4
5
Name:
Account Number:
6
ID:
Software:
So, after running to sub/function, I would have:
[D]=Destination [S]=Source
[D]B2=[S]A3
[D]D2=[S]B3
[D]B3=[S]C3
[D]D3=[S]D3
[D]B5=[S]A4
[D]D5=[S]B4
[D]B6=[S]C4
[D]D6=[S]D4
And so on with 2 rows from the source getting put into the 8 fields of the destination workbook. I have some very basic code at this point but I know this is pretty convoluted. Here is what I've come up with so far which just loops through all of the visible rows and prints out the lines from the range from A2 through the last cell in D with data in it to the immediate window. I've removed it from my main project and just put it all in 2 new workbooks to simplify everything. Ultimately, I'm going to print each page when the destination gets all 8 fields updated and move on to the next page. My code so far:
Sub AddToPrintoutAndPrint()
Dim rng As Range, lastRow As Long
Dim myArray() As Variant, myString() As String
Dim cell As Range, x As Long, y As Long
Dim ws As Worksheet: Set ws = Sheet1 ' Sheet1
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set rng = Range("A2:D" & lastRow)
For Each cell In rng.SpecialCells(xlCellTypeVisible)
ReDim Preserve myArray(x)
myArray(x) = cell.Value
x = x + 1
Next cell
For x = LBound(myArray) To UBound(myArray)
Debug.Print Trim$(myArray(x))
Next x
Set ws = Nothing
End Sub
Thanks for any suggestions
Edit: New block of code to support printing multiple lines
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Dim rowCounter As Integer
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng.SpecialCells(xlCellTypeVisible))
'This is used to keep a running total of how many rows
'were populated. Since the entries are three rows apart
'we can use the offset function in the loop to choose
'the correct entry. This is also flexible enough
'such that if you ever wanted three or more entries
'per sheet, it will work.
rowCounter = 0
For Each itm In coll
wsDest.Range("B2").Offset(rowCounter * 3).Value = itm(0)
wsDest.Range("D2").Offset(rowCounter * 3).Value = itm(1)
wsDest.Range("B3").Offset(rowCounter * 3).Value = itm(2)
wsDest.Range("D3").Offset(rowCounter * 3).Value = itm(3)
'Increment rowcouter, looping around if you surpass
'two (or any future max number of items)
rowCounter = (rowCounter + 1) Mod 2
'If rowCounter has reset to 0, that means its time to
'print or whatever yuo need to do. Do it below
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
Next itm
'Here we check if rowcounter does not equal 0. This indicates
'that the loop ended with an odd number of elements, and should be
'printed out to flush that "buffer"
If rowCounter <> 0 Then
'Do final printout
Debug.Print wsDest.Range("B2").Value
Debug.Print wsDest.Range("B5").Value
End If
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I'd manage it a bit differently. First, I don't think it's wise to ReDim an array in a loop. I'm not sure how efficiently VBA manages resizing arrays, but it can be an expensive process.
I'd store the relevant values from each row into a collection. The items in the collection will be an array with the relevant fields. This collection can then be looped over, with the data being dropped into the relevant fields (and then printed, or whatever needs to be done).
Let me know if this gets you started.
Sub RunIt()
Dim rng As Range
Dim lastRow As Long
Dim ws As Worksheet
Dim coll As Collection
Dim wsDest As Worksheet
Set ws = Sheets("Sheet1")
lastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
Set wsDest = Sheets("Sheet2")
Set rng = Range("A2:A" & lastRow)
Set coll = GetUserInfo(rng)
For Each itm In coll
wsDest.Range("B2").Value = itm(0)
wsDest.Range("D2").Value = itm(1)
wsDest.Range("B3").Value = itm(2)
wsDest.Range("D3").Value = itm(3)
'Maybe do your print routine here, and then reload
Next itm
End Sub
Function GetUserInfo(rng As Range) As Collection
Dim c As Collection
Dim cel As Range
Dim a(0 To 3)
Set c = New Collection
For Each cel In rng
a(0) = cel.Value
a(1) = cel.Offset(, 1).Value
a(2) = cel.Offset(, 2).Value
a(3) = cel.Offset(, 3).Value
c.Add a
Next cel
'Return the collection
Set GetUserInfo = c
End Function
I've got three sheets - main,specimen and output in an excel workbook. The sheet main and speciment contain some information. Some of the information in two sheets are identical but few of them are not. My intention is to paste those information in output which are available in speciment but not in main.
I've tried like [currently it fills in lots of cells producing duplicates]:
Sub getData()
Dim cel As Range, celOne As Range, celTwo As Range
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("main")
Dim ws1 As Worksheet: Set ws1 = ThisWorkbook.Worksheets("specimen")
Dim ws2 As Worksheet: Set ws2 = ThisWorkbook.Worksheets("output")
For Each cel In ws.Range("A2:A" & ws.Cells(Rows.Count, 1).End(xlUp).row)
For Each celOne In ws1.Range("A2:A" & ws1.Cells(Rows.Count, 1).End(xlUp).row)
If cel(1, 1) <> celOne(1, 1) Then ws2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).value = celOne(1, 1)
Next celOne
Next cel
End Sub
main contains:
UNIQUE ID FIRST NAME LAST NAME
A0000477 RICHARD NOEL AARONS
A0001032 DON WILLIAM ABBOTT
A0290191 REINHARDT WESTER CARLSON
A0290284 RICHARD WARREN CARLSON
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
A0003916 GEORGES YOUSSEF ACCAOUI
specimen contains:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290284 RICHARD WARREN CARLSON
A0290688 THOMAS A CARLSTROM
A0002029 RAYMOND MAX ABEL
A0002864 DARRYL SCOTT ABLING
output should contain [EXPECTED]:
UNIQUE ID FIRST NAME LAST NAME
A0288761 ROBERT HOWARD CARLISLE
A0290688 THOMAS A CARLSTROM
How can I achieve that?
If you have the latest version of Excel, with the FILTER function and dynamic arrays, you can do this with an Excel formula.
I changed your Main and Specimen data into tables.
On the Output worksheet you can then enter this formula into a single cell:
=FILTER(specTbl,ISNA(MATCH(specTbl[UNIQUE ID],mnTbl[UNIQUE ID],0)))
The remaining fields will autopopulate with the results.
For a VBA solution, I like to use Dictionaries, and VBA arrays for speed.
'set reference to microsoft scripting runtime
' or use late-binding
Option Explicit
Sub findMissing()
Dim wsMain As Worksheet, wsSpec As Worksheet, wsOut As Worksheet
Dim dN As Dictionary, dM As Dictionary
Dim vMain As Variant, vSpec As Variant, vOut As Variant
Dim I As Long, v As Variant
With ThisWorkbook
Set wsMain = .Worksheets("Main")
Set wsSpec = .Worksheets("Specimen")
Set wsOut = .Worksheets("Output")
End With
'Read data into vba arrays for processing speed
With wsMain
vMain = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
With wsSpec
vSpec = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp)).Resize(columnsize:=3)
End With
'add ID to names dictionary
Set dN = New Dictionary
For I = 2 To UBound(vMain, 1)
dN.Add Key:=vMain(I, 1), Item:=I
Next I
'add missing ID's to missing dictionary
Set dM = New Dictionary
For I = 2 To UBound(vSpec, 1)
If Not dN.Exists(vSpec(I, 1)) Then
dM.Add Key:=vSpec(I, 1), Item:=WorksheetFunction.Index(vSpec, I, 0)
End If
Next I
'write results to output array
ReDim vOut(0 To dM.Count, 1 To 3)
vOut(0, 1) = "UNIQUE ID"
vOut(0, 2) = "FIRST NAME"
vOut(0, 3) = "LAST NAME"
I = 0
For Each v In dM.Keys
I = I + 1
vOut(I, 1) = dM(v)(1)
vOut(I, 2) = dM(v)(2)
vOut(I, 3) = dM(v)(3)
Next v
Dim R As Range
With wsOut
Set R = .Cells(1, 1)
Set R = R.Resize(UBound(vOut, 1) + 1, UBound(vOut, 2))
With R
.EntireColumn.Clear
.Value = vOut
.Style = "Output"
.EntireColumn.AutoFit
End With
End With
End Sub
Both show the same result (except the formula solution does not bring over the column headers; but you can do that with a formula =mnTbl[#Headers] in the cell above the original formula above).
Another option is to join the values of each row in each range and store them in arrays.
Then compare arrays and output the unique values.
In this case, your uniques come from evaluating the whole row, and not just the Unique ID.
Please read code's comments and adjust it to fit your needs.
Public Sub OutputUniqueValues()
Dim mainSheet As Worksheet
Dim specimenSheet As Worksheet
Dim outputSheet As Worksheet
Dim mainRange As Range
Dim specimenRange As Range
Dim mainArray As Variant
Dim specimenArray As Variant
Dim mainFirstRow As Long
Dim specimenFirstRow As Long
Dim outputCounter As Long
Set mainSheet = ThisWorkbook.Worksheets("main")
Set specimenSheet = ThisWorkbook.Worksheets("specimen")
Set outputSheet = ThisWorkbook.Worksheets("output")
' Row at which the output range will be printed (not including headers)
outputCounter = 2
' Process main data ------------------------------------
' Row at which the range to be evaluated begins
mainFirstRow = 2
' Turn range rows into array items
mainArray = ProcessRangeData(mainSheet, mainFirstRow)
' Process specimen data ------------------------------------
' Row at which the range to be evaluated begins
specimenFirstRow = 2
' Turn range rows into array items
specimenArray = ProcessRangeData(specimenSheet, specimenFirstRow)
' Look for unique values and output results in sheet
OutputUniquesFromArrays outputSheet, outputCounter, mainArray, specimenArray
End Sub
Private Function ProcessRangeData(ByVal dataSheet As Worksheet, ByVal firstRow As Long) As Variant
Dim dataRange As Range
Dim evalRowRange As Range
Dim lastRow As Long
Dim counter As Long
Dim dataArray As Variant
' Get last row in sheet (column 1 = column A)
lastRow = dataSheet.Cells(dataSheet.Rows.Count, 1).End(xlUp).Row
' Set the range of specimen sheet
Set dataRange = dataSheet.Range("A" & firstRow & ":C" & lastRow)
' Redimension the array to the number of rows in range
ReDim dataArray(dataRange.Rows.Count)
counter = 0
' Join each row values so it's easier to compare them later and add them to an array
For Each evalRowRange In dataRange.Rows
' Use Trim function if you want to omit the first and last characters if they are spaces
dataArray(counter) = Trim(evalRowRange.Cells(1).Value) & "|" & Trim(evalRowRange.Cells(2).Value) & "|" & Trim(evalRowRange.Cells(3).Value)
counter = counter + 1
Next evalRowRange
ProcessRangeData = dataArray
End Function
Private Sub OutputUniquesFromArrays(ByVal outputSheet As Worksheet, ByVal outputCounter As Long, ByVal mainArray As Variant, ByVal specimenArray As Variant)
Dim specimenFound As Boolean
Dim specimenCounter As Long
Dim mainCounter As Long
' Look for unique values ------------------------------------
For specimenCounter = 0 To UBound(specimenArray)
specimenFound = False
' Check if value in specimen array exists in main array
For mainCounter = 0 To UBound(mainArray)
If specimenArray(specimenCounter) = mainArray(mainCounter) Then specimenFound = True
Next mainCounter
If specimenFound = False Then
' Write values to output sheet
outputSheet.Range("A" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(0)
outputSheet.Range("B" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(1)
outputSheet.Range("C" & outputCounter).Value = Split(specimenArray(specimenCounter), "|")(2)
outputCounter = outputCounter + 1
End If
Next specimenCounter
End Sub
Previously, when I created the worksheets index 1,2,3 in excel,
it can be sorted into like this in index 1 2 and 3 respectively
But now if i stop creating worksheets in excel but through VBA instead, the data cant be populated and it leaves index 1,2 and 3 empty.
This is the code that I used for populating the data but with the addition of add.sheets. The add.sheets here are for creating index1,2,3 worksheets but they doesn't trigger the program to continue to populate the data even though these worksheets exists when I program them in VBA.
Sub UpdateVal()
Static count As Long
Dim iRow As Long
Dim aRow As Long
Dim a As Long
Dim b As Long
Dim selectRange As Range
Dim lastline As Integer
Dim sheetname As String
Dim indexrowcount As Integer
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Result")
Set site_ai = Sheets.Add(after:=Sheets(Worksheets.count))
site_ai.Name = "Index1"
Set site_bi = Sheets.Add(after:=Sheets(Worksheets.count))
site_bi.Name = "Index2"
Set site_ci = Sheets.Add(after:=Sheets(Worksheets.count))
site_ci.Name = "Index3"**
'^additional codes sheets.Add added here for creating worksheets namely index1,2,3
j = 2
iRow = 1
lastline = ws.UsedRange.Rows.count
While iRow < lastline + 1
a = iRow + 1
b = iRow + 17 ' Max Group Size with Same name in F to H column
count = 1
If ws.Cells(iRow, "F").Value = "Martin1" Then
sheetname = "Index1"
ElseIf ws.Cells(iRow, "F").Value = "John1" Then
sheetname = "Index2"
Else
sheetname = "Index3"
End If
For aRow = a To b
If ws.Cells(iRow, "F") = ws.Cells(aRow, "F") And ws.Cells(iRow, "G") = ws.Cells(aRow, "G") And ws.Cells(iRow, "H") = ws.Cells(aRow, "H") Then
count = count + 1
Else
Set selectRange = Range("A" & iRow & ":J" & aRow - 1)
selectRange.Copy
indexrowcount = Sheets(sheetname).UsedRange.Rows.count
Sheets(sheetname).Range("A" & indexrowcount).PasteSpecial xlPasteAll
iRow = iRow + count
Exit For
End If
Next aRow
Wend
End Sub
what am I missing here and how should i solve it?
Your code is too confusing. If your example data is accurate, I don't understand why you need to check all three columns. You can accomplish what you are trying to do, by just using column F. If your data is already sorted as shown, then I would loop through column F testing for duplicates until no match. I would then add a worksheet and name it using the start cells' value. Then copy the rows from the start cell to the current rwNbr - 1 and paste to the new worksheet. Reset the start cell for the next group and loop.
Sub SaveRangewithConsecutiveDuplicateValuestoNewSheet()
'Define all variables
Dim wb As Workbook, ws As Worksheet, sCel As Range, rwNbr As Long
Set wb = ThisWorkbook 'Set workbook variable
Set ws = wb.Worksheets("Sheet1") 'set worksheet variable using workbook variable
Set sCel = ws.Cells(1, 6) 'Set the first start cell variable to test for duplicate values
Application.DisplayAlerts = False
For rwNbr = 2 To ws.Cells(ws.Rows.count, 6).End(xlUp).Offset(1).Row Step 1 'Loop
If ws.Cells(rwNbr, 6).Value <> sCel.Value Then 'loop until the value changes
wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.count)).Name = sCel.Value 'Add sheet and name based on the first cell of group
ws.Range(sCel, ws.Cells(rwNbr - 1, 6)).EntireRow.Copy Destination:=ActiveSheet.Range("A1") 'select group of consecutive duplicates
Set sCel = ws.Cells(rwNbr, 6) 'reset start cell to test for the next group of consecutive duplicates
End If
Next rwNbr
Application.DisplayAlerts = True
End Sub
I have a worksheet of data that has four columns. I want the spreadsheet to add 3 rows after each group based on column D. Column D has the department for the transactions. All department transactions are listed in a row. So Excel just needs to find the change in department and enter three rows after that section.
I have tried this code I found here. It puts a row after every line it sees the department in.
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("IMPORT-WIP") 'better define by name: ThisWorkbook.Worksheets("MySheet")
Dim LastRow_f As Long
LastRow_f = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
ws.Range("A1:D" & LastRow_f).AutoFilter Field:=12, Criteria1:="HR DEPARTMENT"
Dim FilteredData As Range
Set FilteredData = ws.Range("D2:D" & LastRow_f).SpecialCells(xlCellTypeVisible)
Dim iArea As Long
Dim iRow As Long
For iArea = FilteredData.Areas.Count To 1 Step -1 'loop from last to first area
For iRow = FilteredData.Areas(iArea).Rows.Count To 1 Step -1 'loop from last row to first row in each area
With FilteredData.Areas(iArea).Rows(iRow) '<-- this represents the current row we are in the loop
.Offset(RowOffset:=1).EntireRow.Insert Shift:=xlDown
.Offset(RowOffset:=1).EntireRow.Interior.Color = RGB(192, 192, 192)
End With
Next iRow
Next iArea
'remove filters
ws.Range("A1:D" & LastRow_f).AutoFilter
This code will insert 3 rows between groups of values (even unique values). The data does not need to be filtered. It will loop through Column D, test the cell above the current cell and, if not the same value, will insert 3 rows between them. You may have to sort the data first, depending on what you want.
Sub InsertRowsBetweenGroups()
Dim ws As Worksheet, lr As Long, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'Change as needed
lr = ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For i = lr - 1 To 2 Step -1
If Cells(i, "D") <> Cells(i - 1, "D") Then
Cells(i, "D").Resize(3).EntireRow.Insert Shift:=xlDown
End If
Next i
End Sub