I have this macro that loops through rows F and G, clearing a range if it finds a duplicate F&G combo.
Right now, if it finds a unique combo (say, F(1) G(2)), it will delete all of those combos.
How can I change this macro to purge every time it clears, so that it is only clearing duplicates directly below the original?
Thanks.
Sub clearDupsA()
Dim lngMyRow As Long
Dim lngMyCol As Long
Dim lngLastRow As Long
Dim objMyUniqueData As Object
Application.ScreenUpdating = False
lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).row
Set objMyUniqueData = CreateObject("Scripting.Dictionary")
For lngMyRow = 1 To lngLastRow
If objMyUniqueData.exists(CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7))) = False Then
objMyUniqueData.Add CStr(Cells(lngMyRow, 6) & Cells(lngMyRow, 7)), Cells(lngMyRow, 6) & Cells(lngMyRow, 7)
Else
Range(Cells(lngMyRow, 6), Cells(lngMyRow, 7)).ClearContents
End If
Next lngMyRow
Set objMyUniqueData = Nothing
On Error GoTo ErrorHandler
ErrorHandler:
Exit Sub
End Sub
do not use a dictionary. Instead just use a variable that gets replaced when a new combo is found:
Sub clearDupsA()
Dim lngMyRow As Long
Dim lngMyCol As Long
Dim lngLastRow As Long
Dim tempHolder As String
Application.ScreenUpdating = False
With ActiveSheet 'Don't let vba determine the sheet
lngLastRow = Range("F:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
For lngMyRow = 1 To lngLastRow
If tempHolder <> (CStr(.Cells(lngMyRow, 6) & .Cells(lngMyRow, 7))) Then
tempHolder = (CStr(.Cells(lngMyRow, 6) & .Cells(lngMyRow, 7)))
Else
.Range(.Cells(lngMyRow, 6), .Cells(lngMyRow, 7)).ClearContents
End If
Next lngMyRow
End With
End Sub
Clear Consecutive Duplicates
Sub clearDupsA()
Const FirstRowAddress As String = "F2:G2"
Const Delimiter As String = "|!|"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim rg As Range
Dim rCount As Long
With ws.Range(FirstRowAddress)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub ' no data
rCount = lCell.Row - .Row + 1
Set rg = .Resize(rCount)
End With
Dim Data() As Variant: Data = rg.Value
Dim r As Long
Dim OldString As String
Dim NewString As String
For r = 1 To rCount
NewString = CStr(Data(r, 1)) & Delimiter & CStr(Data(r, 2))
If StrComp(NewString, OldString, vbTextCompare) = 0 Then
Data(r, 1) = Empty
Data(r, 2) = Empty
Else
OldString = NewString
End If
Next r
rg.Value = Data
End Sub
I want to look for value of Forecast in cell (F column) (more than one instance - unique key is Prod and Cust), then copy corresponding row values to other rows identified by Edited Forecast value in another cell (more than one instance - unique key is Prod and Cust (same column).)
This is only copying Row values.
Private AutomationObject As Object
Sub Save ()
Dim Worksheet as Worksheet
Set Worksheet = ActiveWorkbook.Worksheets("Sheet")
Worksheet.Range("M18:AX18").Value = Worksheet.Range("M15:AX15").Value
End Sub
Fill Blanks (Unique Dictionary)
Option Explicit
Sub FillBlanks()
Const sFirstCellAddress As String = "D3"
Const sDelimiter As String = "#"
Const dCols As String = "I:K"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range
Dim rCount As Long
With ws.Range(sFirstCellAddress)
Dim lCell As Range: Set lCell = .Resize(ws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Sub
rCount = lCell.Row - .Row + 1
Set srg = .Resize(rCount, 2)
End With
Dim sData As Variant: sData = srg.Value
Dim drg As Range: Set drg = srg.EntireRow.Columns(dCols)
Dim dcCount As Long: dcCount = drg.Columns.Count
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim rg As Range
Dim r As Long
Dim sString As String
For r = 1 To rCount
sString = sData(r, 1) & sDelimiter & sData(r, 2)
If Application.CountBlank(drg.Rows(r)) = dcCount Then
If dict.Exists(sString) Then
If IsArray(dict(sString)) Then
drg.Rows(r).Value = dict(sString)
Else
dict(sString).Add drg.Rows(r)
End If
Else
Set dict(sString) = New Collection
dict(sString).Add drg.Rows(r)
End If
Else
If dict.Exists(sString) Then
If IsArray(dict(sString)) Then
'drg.Rows(r).Value = dict(sString) ' overwrite!?
Else
For Each rg In dict(sString)
rg.Value = drg.Rows(r).Value
Next rg
dict(sString) = drg.Rows(r).Value
End If
Else
dict(sString) = drg.Rows(r).Value
End If
End If
Next r
MsgBox "Data updated.", vbInformation
End Sub
I have workbook with three sheets.
I copy data from sheet1 to sheet2 & sheet3 depend on specific condition on sheet1, value = "Yes" on columns T or U.
The below code works fine using for Loop, but it is slow.
Now I transferred all data of sheet1 to array .
MyArray = Sheet1.Range("A3:U" & LastRow).Value2
is it possible to copy data from this array (by condition if specific value on it) to the other sheets .
I am new to vba , so any help will be appreciated .
Sub Copy_Data_On_Condition()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim LastRow As Long
Dim ris_column As Range
Dim cell As Object
Dim DestRng As Range
Dim MyArray() As Variant
LastRow = Sheet1.Cells(Rows.count, 1).End(xlUp).Row
MyArray = Sheet1.Range("A3:U" & LastRow).Value2
Set ris_column = Sheet1.Range("T3:T" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
Set DestRng = Sheet2.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
cell.EntireRow.Copy DestRng
End If
Next cell
Set ris_column = Sheet1.Range("U3:U" & LastRow)
For Each cell In ris_column
If cell.value = "Yes" Then
Set DestRng = Sheet3.Range("A" & Rows.count).End(xlUp).Offset(1, 0)
cell.EntireRow.Copy DestRng
End If
Next cell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Update: Both two answers works perfectly , I tested on a sheet with total 2180 rows and copied rows about 1200. "FaneDure" Code takes about 4 second to finish and "Super Symmetry" code takes 0.07 of second which is significantly faster .
Please, try the next code:
Sub Copy_Data_On_Condition()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet, LastRow As Long
Dim arr_column, rngT As Range, rngU As Range, i As Long, lastCol As Long
Set sh1 = Sheet1: Set sh2 = Sheet2: Set sh3 = Sheet3 'only to make the code more compact
LastRow = sh1.cells(rows.count, 1).End(xlUp).row 'last row in A:A column
lastCol = sh1.UsedRange.Columns.count 'last column of Sheet1, to avoid copying the whole row
arr_column = sh1.Range("T3:U" & LastRow).Value2 'put in an array the columns to be processed against "Yes" string
'process both columns in the same iteration to make code faster
For i = 1 To UBound(arr_column) 'iterate between the array rows and process the columns values
If arr_column(i, 1) = "Yes" Then 'finding a match in column T:T:
If rngT Is Nothing Then 'if the rngT keeping the range to be copied is not Set (yet)
Set rngT = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
Else
Set rngT = Union(rngT, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
End If
End If
If arr_column(i, 2) = "Yes" Then 'finding a match in column U:U:
If rngU Is Nothing Then 'if the rngU keeping the range to be copied is not Set (yet)
Set rngU = sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol)) 'the range is Set by the used range suitable row
Else
Set rngU = Union(rngU, sh1.Range(sh1.cells(i + 2, 1), sh1.cells(i + 2, lastCol))) 'add the suitable row to the existing range
End If
End If
Next i
If Not rngT Is Nothing Then 'if rngT has been set (it contains at least a row), copy it in Sheet2
rngT.Copy Destination:=sh2.Range("A" & sh2.rows.count).End(xlUp).Offset(1) 'copy the range at once
End If
If Not rngU Is Nothing Then 'if rngU has been set (it contains at least a row), copy it in Sheet3
rngU.Copy Destination:=sh3.Range("A" & sh3.rows.count).End(xlUp).Offset(1) 'copy the range at once
End If
End Sub
Because a direct autofilter is not an option, processing the array in memory should give you the fastest result as it minimises the interaction of VBA with the excel application. I believe the following should make your code significantly faster:
Sub Copy_Data_On_Condition()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim srcData As Variant
Dim sht2Data() As Variant
Dim sht2Rows As Long
Dim sht2CriteriaCol As Long: sht2CriteriaCol = 20 'T
Dim sht3Data() As Variant
Dim sht3Rows As Long
Dim sht3CriteriaCol As Long: sht3CriteriaCol = 21 'U
Dim outputCols As Long
Dim i As Long, j As Long
With Sheet1
srcData = .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row).Value
End With
outputCols = UBound(srcData, 2)
For i = LBound(srcData) To UBound(srcData)
If srcData(i, sht2CriteriaCol) = "Yes" Then
sht2Rows = sht2Rows + 1
ReDim Preserve sht2Data(1 To outputCols, 1 To sht2Rows)
For j = 1 To outputCols
sht2Data(j, sht2Rows) = srcData(i, j)
Next j
End If
If srcData(i, sht3CriteriaCol) = "Yes" Then
sht3Rows = sht3Rows + 1
ReDim Preserve sht3Data(1 To outputCols, 1 To sht3Rows)
For j = 1 To outputCols
sht3Data(j, sht3Rows) = srcData(i, j)
Next j
End If
Next i
If sht2Rows > 0 Then
Sheet2.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht2Rows, outputCols).Value = WorksheetFunction.Transpose(sht2Data)
End If
If sht3Rows > 0 Then
Sheet3.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Resize(sht3Rows, outputCols).Value = WorksheetFunction.Transpose(sht3Data)
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox "Time taken: " & Format(Timer - dStart, "0.000s")
End Sub
Another fast option is to add a dummy sheet (if possible), use autofilter then delete the dummy worksheet. This is very fast and the code is very simple:
Sub Copy_Data_On_Condition2()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Sheet1.Copy After:=Sheet1
With ActiveSheet
With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
.Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20
.Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
.Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.AutoFilter
End With
.Delete
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - dStart, "0.000")
End Sub
Edit: (following comment and file share)
Your worksheet is protected but without password. Therefore, you can actually do autfilter in place without having to add a new dummy sheet. Your autfilter becomes:
Sub Copy_Data_On_Condition2()
Dim dStart As Double: dStart = Timer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Check first if there's autfilter
If Sheet1.AutoFilterMode Then Sheet1.AutoFilter.ShowAllData
With Sheet2
If .AutoFilterMode Then .AutoFilter.ShowAllData
.Rows("4:" & .Rows.Count).ClearContents
End With
With Sheet3
If .AutoFilterMode Then .AutoFilter.ShowAllData
.Rows("4:" & .Rows.Count).ClearContents
End With
'=========== Super Symmetry Code _ Auto Filter
With Sheet1
.Unprotect
With .Range("A3:U" & .Cells(Rows.Count, 1).End(xlUp).Row)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20, Criteria1:="Yes"
.Copy Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
.Rows(1).Offset(-1, 0).AutoFilter Field:=20
.Rows(1).Offset(-1, 0).AutoFilter Field:=21, Criteria1:="Yes"
.Copy Destination:=Sheet3.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
End With
.Protect
End With
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox Format(Timer - dStart, "0.000")
End Sub
Autofilter is your best friend here if and when your data grows.
Copy Filtered Data
In this solution, it is assumed that you always want to start your resulting data in a given cell (dFirst) removing the previous contents.
Option Explicit
Sub CopyData()
Const sFirst As String = "A3"
Dim sCols As Variant: sCols = Array(20, 21)
Dim sCriteria As Variant: sCriteria = Array("Yes", "Yes")
Dim dFirst As Variant: dFirst = Array("A3", "A3")
Dim AutoFitColumns As Variant: AutoFitColumns = Array(True, True)
Dim sws As Worksheet: Set sws = Sheet1
Dim dws As Variant: dws = Array(Sheet2, Sheet3)
Dim srg As Range: Set srg = RefRange(sws.Range(sFirst))
If srg Is Nothing Then Exit Sub
Dim dData As Variant
Dim n As Long
For n = LBound(dws) To UBound(dws)
dData = GetCriteriaRows(srg, sCriteria(n), sCols(n))
If Not IsEmpty(dData) Then
WriteData dData, dws(n).Range(dFirst(n)), AutoFitColumns(n)
End If
Next n
End Sub
' Creates a reference to the range from a given first cell (range)
' to the cell at the intersection of the last non-empty row
' and the last non-empty column.
Function RefRange( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1)
Dim rg As Range
Set rg = .Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count - .Column + 1)
Dim lCell As Range
Set lCell = rg.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Function
Dim lRow As Long: lRow = lCell.Row
Set lCell = rg.Find("*", , , , xlByColumns, xlPrevious)
Set RefRange = .Resize(lRow - .Row + 1, lCell.Column - .Column + 1)
End With
End Function
' Returns a 2D one-based array containing the rows with matching criteria
' in a given column.
Function GetCriteriaRows( _
ByVal srg As Range, _
ByVal CriteriaString As String, _
Optional ByVal CriteriaColumn As Long = 1) _
As Variant
If srg Is Nothing Then Exit Function
If Len(CriteriaString) = 0 Then Exit Function
If CriteriaColumn < 0 Then Exit Function
Dim drCount As Long: drCount = Application.CountIf(srg, CriteriaString)
If drCount = 0 Then Exit Function
Dim srCount As Long: srCount = srg.Rows.Count
Dim cCount As Long: cCount = srg.Columns.Count
If CriteriaColumn > cCount Then Exit Function
Dim sData As Variant
If srCount + cCount = 2 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim cValue As Variant
Dim r As Long, c As Long, n As Long
For r = 1 To srCount
cValue = CStr(sData(r, CriteriaColumn))
If cValue = CriteriaString Then
n = n + 1
For c = 1 To cCount
dData(n, c) = sData(r, c)
Next c
End If
Next r
GetCriteriaRows = dData
End Function
' Writes the values from a 2D one-based array to a range.
Sub WriteData( _
ByVal Data As Variant, _
ByVal FirstCellRange As Range, _
Optional ByVal AutoFitColumns As Boolean = False)
If FirstCellRange Is Nothing Then Exit Sub
If IsEmpty(Data) Then Exit Sub
Dim srCount As Long: srCount = UBound(Data, 1)
Dim scCount As Long: scCount = UBound(Data, 2)
Dim DoesFit As Boolean
Dim DoesNotFitExactly As Boolean
With FirstCellRange.Cells(1)
If .Worksheet.Columns.Count - .Column + 1 >= scCount Then
Select Case .Worksheet.Rows.Count - .Row + 1
Case srCount
DoesFit = True
Case Is > srCount
DoesFit = True
DoesNotFitExactly = True
End Select
End If
If DoesFit Then
Dim drg As Range: Set drg = .Resize(srCount, scCount)
drg.Value = Data
If DoesNotFitExactly Then
drg.Resize(.Worksheet.Rows.Count - .Row - srCount + 1) _
.Offset(srCount).ClearContents
End If
If AutoFitColumns Then
drg.EntireColumn.AutoFit
End If
End If
End With
End Sub
' Returns a 2D one-based array containing the values of a range
' (Not used because it is incorporated in 'GetCriteriaRows').
Function GetRange( _
ByVal rg As Range) _
As Variant
If rg Is Nothing Then Exit Function
Dim Data As Variant
If rg.Rows.Count + rg.Columns.Count = 2 Then
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
Else
Data = rg.Value
End If
GetRange = Data
End Function
If you don't want to consider autofilter option.
Option Explicit
Sub Copy_Data_On_Condition()
'_____________________________________________________________
Dim StartTime As Double
Dim SecondsElapsed As Double
StartTime = Timer
'_____________________________________________________________
Dim arr, findT As Range, findU As Range, arrStr As String, i As Long, j As Long
Dim LastRow As Long, ColT As Range, ColU As Range, k As Long, n As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
k = 3000
For j = 2 To LastRow Step WorksheetFunction.Min(LastRow, k)
'_____________________________________________________________
'Evaluate Column T for "Yes" and create range findT
Set ColT = Sheet1.Range("T" & j + 1 & ":T" & WorksheetFunction.Min(j + k, LastRow))
arr = Evaluate("Transpose(IF((" & ColT.Address & "=" & """YES""" & ")," & _
"""A""" & "& ROW(" & ColT.Address & ") &" & _
""":U""" & "& ROW(" & ColT.Address & "),""0""))")
arrStr = Replace(Join(arr, ","), ",0", "")
If Left(arrStr, 2) = "0," Then
arrStr = Right(arrStr, Len(arrStr) - 2)
End If
For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
arrStr = WorksheetFunction.Substitute(arrStr, ",", "|", n)
Next n
arr = Split(arrStr, "|")
For n = 0 To UBound(arr)
If findT Is Nothing Then
'arr = Split(arrStr, "|")
Set findT = Evaluate(arr(n))
Else
Set findT = Union(Evaluate(arr(n)), findT)
End If
Next n
Debug.Print findT.Cells.Count
'_____________________________________________________________
'Evaluate Column U for "Yes" and create range findU
Set ColU = Sheet1.Range("U" & j + 1 & ":U" & WorksheetFunction.Min(j + k, LastRow))
arr = Evaluate("Transpose(IF((" & ColU.Address & "=" & """YES""" & ")," & _
"""A""" & "& ROW(" & ColU.Address & ") &" & _
""":U""" & "& ROW(" & ColU.Address & "),""0""))")
arrStr = Replace(Join(arr, ","), ",0", "")
If Left(arrStr, 2) = "0," Then
arrStr = Right(arrStr, Len(arrStr) - 2)
End If
For n = 15 To Len(arrStr) - Len(Replace(arrStr, ",", "", , , vbTextCompare)) Step 15
arrStr = WorksheetFunction.Substitute(arrStr, ",", "|")
Next n
arr = Split(arrStr, "|")
For n = 0 To UBound(arr)
If findU Is Nothing Then
'arr = Split(arrStr, "|")
Set findU = Evaluate(arr(n))
Else
Set findU = Union(Evaluate(arr(n)), findU)
End If
Next n
Debug.Print findU.Cells.Count
'_____________________________________________________________
Next j
findT.Copy Sheet2.Range("A" & Sheet2.Rows.Count).End(xlUp).Offset(1)
findU.Copy Sheet3.Range("A" & Sheet3.Rows.Count).End(xlUp).Offset(1)
'_____________________________________________________________
SecondsElapsed = Round(Timer - StartTime, 2)
Debug.Print "This code ran successfully in " & SecondsElapsed & " seconds"
End Sub
I want to create a VBA code where it could copy all the unique file owner emails into one cell and all the file locations into the cell next to it, being separated by a comma. Is that possible? I created a code to grab the unique values and pasted into cell L1 and create a table, and this is what I have so far:
This is an example of what Excel would look like
This is an example what I want the VBA code to do
Public Sub unique_emails()
Columns("B:B").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("L1" _
), Unique:=True
Range("L1").Select
Dim tbl As ListObject
Dim rng As Range
Set rng = Range(Range("L1"), Range("L1").SpecialCells(xlLastCell))
Set tbl = ActiveSheet.ListObjects.Add(xlSrcRange, rng, , xlYes)
tbl.TableStyle = "TableStyleMedium16"
End Sub
Unique Delimited (Dictionary)
Adjust the values in the constants section.
Option Explicit
Public Sub unique_emails()
Const sFirst As String = "A1"
Const dFirst As String = "L1"
Const Delimiter As String = ", "
' Worksheet
Dim ws As Worksheet: Set ws = ActiveSheet
' Source Range
Dim rg As Range
With ws.Range(sFirst).Resize(, 2)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lCell Is Nothing Then Exit Sub
Set rg = .Resize(lCell.Row - .Row + 1)
End With
Dim rCount As Long: rCount = rg.Rows.Count
' Source Range to Array
Dim Data As Variant: Data = rg.Value
Dim n As Long
If rCount > 1 Then
' Array to Dictionary
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim Key As Variant
For n = 2 To rCount
Key = Data(n, 2)
If Not IsError(Key) Then
If Len(Key) > 0 Then
If dict.Exists(Key) Then
dict(Key) = dict(Key) & Delimiter & Data(n, 1)
Else
dict(Key) = Data(n, 1)
End If
End If
End If
Next n
' Dictionary to Array
n = 1
For Each Key In dict.Keys
n = n + 1
Data(n, 1) = Key
Data(n, 2) = dict(Key)
Next Key
Else
n = 1
End If
' Switch Headers
Key = Data(1, 1): Data(1, 1) = Data(1, 2): Data(1, 2) = Key
' Array to Destination Range
With ws.Range(dFirst).Resize(, 2)
.Resize(n).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - n + 1).Offset(n).ClearContents
End With
End Sub
We have a spreadsheet of hundreds of Employees and their respective roles that looks like this:
We need to reformat this spreadsheet so that each role is its own separate line item:
We found a VBA Macro that allows us to insert a row if "/" is found in our Roles column, but it only inserts one row instead of based on the number of roles that person has. The rows inserted are also blank.
Sub Insertrowbelow()
'updateby Extendoffice
Dim i As Long
Dim xLast As Long
Dim xRng As Range
Dim xTxt As String
On Error Resume Next
xTxt = Application.ActiveWindow.RangeSelection.Address
Set xRng = Application.InputBox("please select the column with specific text:", "Kutools for Excel", xTxt, , , , , 8)
If xRng Is Nothing Then Exit Sub
If (xRng.Columns.Count > 1) Then
MsgBox "the selected range must be one column", , "Kutools for Excel"
Exit Sub
End If
xLast = xRng.Rows.Count
For i = xLast To 1 Step -1
If InStr(1, xRng.Cells(i, 1).Value, "/") > 0 Then
Rows(xRng.Cells(i + 1, 1).Row).Insert shift:=xlDown
End If
Next
End Sub
Is there a way to add on to this code snippet so that we can get our spreadsheet formatted correctly?
You can use Split to split the roles into separate roles. The rest of the code is boilerplate.
SourceRow = 1
DestinationRow = 1
For SourceRow = 1 To LastSourceRow
Employee = SourceWorksheet.Cells(SourceRow, 1).Value
Roles = Split(SourceWorksheet.Cells(SourceRow, 2).Value, "/")
For i = LBound(Roles) To UBound(Roles)
DestinationWorksheet.Cells(DestinationRow, 1).Value = Employee
DestinationWorksheet.Cells(DestinationRow, 2).Value = Roles(i)
DestinationRow = DestinationRow + 1
Next i
Next SourceRow
Split Column
Adjust the values in the constants section.
Option Explicit
Sub unPivot()
Const wsName As String = "Sheet1"
Const HeaderRow As Long = 1
Const Header As String = "Employee"
Const Delimiter As String = " / "
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sCell As Range
With wb.Worksheets(wsName).Rows(HeaderRow)
Set sCell = .Find(Header, .Cells(.Cells.Count), xlFormulas, xlWhole)
End With
If sCell Is Nothing Then
MsgBox "The header '" & Header & "' was not found.", _
vbCritical, "Missing Header"
Exit Sub
End If
Dim dcell As Range: Set dcell = sCell.Offset(1)
Dim srg As Range
With dcell
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then
MsgBox "No data found.", vbCritical, "No Data"
Exit Sub
End If
Set srg = .Resize(lCell.Row - .Row + 1, 2)
End With
Dim Data As Variant: Data = srg.Value
Dim srCount As Long: srCount = UBound(Data, 1)
ReDim Preserve Data(1 To srCount, 1 To 3)
Dim drCount As Long
Dim r As Long
For r = 1 To srCount
Data(r, 2) = Split(Data(r, 2), Delimiter)
Data(r, 3) = UBound(Data(r, 2))
drCount = drCount + Data(r, 3) + 1
Next r
Dim Result As Variant: ReDim Result(1 To drCount, 1 To 2)
Dim n As Long
Dim k As Long
For r = 1 To srCount
For n = 0 To Data(r, 3)
k = k + 1
Result(k, 1) = Data(r, 1)
Result(k, 2) = Data(r, 2)(n)
Next n
Next r
With dcell.Resize(, 2)
.Resize(k).Value = Result
'.Resize(.Worksheet.Rows.Count - .Row - k + 1).Offset(k).ClearContents
End With
End Sub