The source picture has names in the 1st column and the 1st row has dated. There are values for each date column. Need to get Dates and their values for each name if there is a value for a particular date.
A Simple Unpivot
Sub UnpivotRCV()
' Define constants.
Const SRC_NAME As String = "Sheet1"
Const DST_NAME As String = "Sheet2"
Const DST_FIRST_CELL As String = "A2"
Const DST_COLUMNS_COUNT As Long = 3 ' fixed
' Reference the workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the source range.
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srCount As Long: srCount = srg.Rows.Count
Dim scCount As Long: scCount = srg.Columns.Count
' Write the values from the source range to the source array.
Dim sData: sData = srg.Value
' Define the destination array.
Dim drCount As Long: drCount = (srCount - 1) * (scCount - 1)
Dim dData(): ReDim dData(1 To drCount, 1 To DST_COLUMNS_COUNT)
Dim sr As Long, sc As Long, dr As Long
' Return the unpivoted values from the source array
' in the destination array.
For sr = 2 To srCount
For sc = 2 To scCount
If Len(CStr(sData(sr, sc))) > 0 Then
dr = dr + 1
dData(dr, 1) = sData(sr, 1) ' row label
dData(dr, 2) = sData(1, sc) ' column label
dData(dr, 3) = sData(sr, sc) ' value
End If
Next sc
Next sr
' Reference the destination range.
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Dim drg As Range: Set drg = dfCell.Resize(dr, DST_COLUMNS_COUNT)
' Write, clear and autfit.
drg.Value = dData
drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).ClearContents
drg.EntireColumn.AutoFit
MsgBox "Data unpivoted.", vbInformation
End Sub
Related
I am a PhD student and new to VBA.
I have been trying to automate sorting 1,8 million data points into a format suitable for data analysis. I am stuck. Would really appreciate anyone's help!
I need to automate the following:
Cutting a range of data in x sequential rows with identical Sequence numbers in column B.
And then paste it onto the right next to the previous range.
I found this code Excel VBA cut and paste rage repeatedly
Sub Cutrange()
Dim i As Long
Dim Lrow As Long
Lrow = Cells(Rows.Count, 1).End(xlUp).Row
Dim oRange As Range, dRange As Range
Set oRange = Range(Cells(1, 1), Cells(124, 14))
Set dRange = Cells(1, 1)
For i = 1 To Lrow
oRange.Offset(124 * i).Cut Destination:=dRange.Offset(, 14 * i)
Next i
End Sub
However, this code cuts and pastes a pre-determined range of cells (124x14). In my data, the number of rows (to be cut and pasted) needs to change based on how many rows have the same Sequence number.
Could anyone kindly help to change this code to fit my purpose or suggest alternative solutions?
Thank you,
Anna
HStack Groups of Data (VBA)
Option Explicit
Sub HStackGroups()
Const SRC_NAME As String = "Sheet1"
Const SRC_FIRST_CELL As String = "B2"
Const DST_NAME As String = "Sheet2"
Const DST_FIRST_CELL As String = "B2"
Const UNIQUE_COLUMN As Long = 1
Const COLUMN_GAP As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = wb.Sheets(SRC_NAME)
Dim srg As Range: Set srg = sws.Range(SRC_FIRST_CELL).CurrentRegion
Dim hData(): hData = srg.Rows(1).Value
Dim cCount As Long: cCount = srg.Columns.Count
Dim srCount As Long: srCount = srg.Rows.Count - 1 ' no headers
Dim sData(): sData = srg.Resize(srCount).Offset(1).Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim sr As Long, drCount As Long, srString As String
For sr = 1 To srCount
srString = CStr(sData(sr, UNIQUE_COLUMN))
If Not dict.Exists(srString) Then
Set dict(srString) = New Collection
End If
dict(srString).Add sr
If dict(srString).Count > drCount Then drCount = dict(srString).Count
Next sr
drCount = drCount + 1 ' 1 for headers
Dim dCount As Long: dCount = cCount + COLUMN_GAP
Dim dcCount As Long
dcCount = dict.Count * dCount - COLUMN_GAP
Dim dData(): ReDim dData(1 To drCount, 1 To dcCount)
Dim Coll, Item, sc As Long, d As Long, dr As Long, dc As Long
For Each Coll In dict.Items
dc = d * dCount
For sc = 1 To cCount
dData(1, dc + sc) = hData(1, sc)
Next sc
dr = 1
For Each Item In Coll
dr = dr + 1
For sc = 1 To cCount
dData(dr, dc + sc) = sData(Item, sc)
Next sc
Next Item
d = d + 1
Next Coll
Dim dws As Worksheet: Set dws = wb.Sheets(DST_NAME)
Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
With dfCell
.Resize(dws.Rows.Count - .Row + 1, dws.Columns.Count - .Column + 1) _
.Clear
End With
drg.Value = dData
drg.EntireColumn.AutoFit
MsgBox "Groups hstacked.", vbInformation
End Sub
I have two workbooks:
Source.xlsm, sheet= Orig and
Destination.xlsm, sheet=New
I am trying to move data between these sheets in a specific way: Example of both sheets before running the macro (the column ordering is on purpose)
My objective is to take only the rows from Orig with today's date and place all of them in a specific ordering to the end of the New sheet. So that after running the macro, New looks like:
Any suggestions as to how to progress would be amazing
I have the following code snippets to start to form a solution, all saved in Source.xlsm. This works apart from the added complication of empty columns in both sheets that would be filled out manually with other data that isn't moved/ edited with during the macro execution. Wihtou the empty columns on each sheet, this works.
Sub TransferToday()
Const CriteriaColumn As Variant = 4
' The leading "0, "-s are used to be able to use sCols(c)
' instead of sCols(c - 1) in the For...Next loop.
Dim sCols() As Variant: sCols = VBA.Array(0, 1, 2, 3, 4)
Dim dCols() As Variant: dCols = VBA.Array(0, 2, 4, 3, 1)
Dim cCount As Long: cCount = UBound(sCols)
Dim Today As Date: Today = Date ' TODAY() in excel
Dim dwb As Workbook: Set dwb = Workbooks("Destination.xlsm")
Dim dws As Worksheet: Set dws = dwb.Worksheets("New")
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion.Resize(, cCount)
' Prevent copying if an occurrence of today's date is found in destination.
' If not needed, out-comment or delete, it doesn't interfere with the rest.
' Dim dCol As Variant
' dCol = dCols(Application.Match(CriteriaColumn, sCols, 0) - 1)
' If IsNumeric(Application.Match(CLng(Today), drg.Columns(dCol), 0)) Then
' MsgBox "Today's data had already been transferred.", vbExclamation
' Exit Sub
' End If
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets("Orig")
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion.Resize(, cCount)
Dim srCount As Long: srCount = srg.Rows.Count
Dim sData() As Variant: sData = srg.Value
Dim dData() As Variant: ReDim dData(1 To srCount, 1 To cCount)
Dim sr As Long
Dim dr As Long
Dim c As Long
For sr = 1 To srCount
If IsDate(sData(sr, CriteriaColumn)) Then ' is a date
If sData(sr, CriteriaColumn) = Today Then ' is today's date
dr = dr + 1
For c = 1 To cCount
dData(dr, dCols(c)) = sData(sr, sCols(c))
Next c
End If
End If
Next sr
If dr = 0 Then
MsgBox "No today's data found.", vbExclamation
Exit Sub
End If
' First Destination Row.
Dim dfrrg As Range: Set dfrrg = drg.Resize(1).Offset(drg.Rows.Count)
dfrrg.Resize(dr).Value = dData
MsgBox "Today's data transferred.", vbInformation
End Sub
Copy to Different Columns
Sub TransferToday()
Const ColumnTitlesList As String = "Name,Product,Quantity,Date"
Const CriteriaColumnTitle As String = "Date" ' need not be in the titles
Dim Today As Date: Today = Date ' TODAY() in excel
Dim ColumnTitles() As String: ColumnTitles = Split(ColumnTitlesList, ",")
Dim cUpper As Long: cUpper = UBound(ColumnTitles)
Dim c As Long ' Column Indexes Counter
' Write the source data to an array.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets("Orig")
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion ' table
Dim shrg As Range: Set shrg = srg.Rows(1) ' header row
Dim srCount As Long: srCount = srg.Rows.Count
Dim sData() As Variant: sData = srg.Value
' Determine the source column indexes.
' Criteria Column
Dim sccIndex As Long
sccIndex = Application.Match(CriteriaColumnTitle, shrg, 0)
' Copy Columns
Dim scIndexes() As Long: ReDim scIndexes(0 To cUpper)
For c = 0 To cUpper
scIndexes(c) = Application.Match(ColumnTitles(c), shrg, 0)
Next c
' Write today's source row data to arrays in a collection.
' This collection will hold...
Dim sColl As Collection: Set sColl = New Collection
' ... as many of these arrays...
Dim sArr As Variant: ReDim sArr(0 To cUpper)
' ... as there are records with today's date found.
' Note that no parentheses ('sArr()') are used to make it more readable
' (understandable) when the same variable is used as the control variable
' in the For Each...Next loop later in the code.
Dim sr As Long ' Source Rows Counter
For sr = 2 To srCount ' skip header row
If IsDate(sData(sr, sccIndex)) Then
If sData(sr, sccIndex) = Today Then
For c = 0 To cUpper
sArr(c) = sData(sr, scIndexes(c))
Next c
sColl.Add sArr
End If
End If
Next sr
Erase sData ' data is in the collection ('sColl')
Dim drCount As Long: drCount = sColl.Count
If drCount = 0 Then
MsgBox "No today's data found.", vbExclamation
Exit Sub
End If
' Write today's source data from the collection to arrays of an array.
' This AKA jagged array will hold...
Dim dJag() As Variant: ReDim dJag(0 To cUpper)
' ... as many of these arrays...
Dim dArr() As Variant: ReDim dArr(1 To drCount, 1 To 1)
' ... as there are columns to be copied.
For c = 0 To cUpper
dJag(c) = dArr
Next c
Dim dr As Long ' Destination Rows Counter
For Each sArr In sColl
dr = dr + 1
For c = 0 To cUpper
dJag(c)(dr, 1) = sArr(c)
Next c
Next sArr
Set sColl = Nothing ' data is in the array of arrays ('dJag')
' Reference the destination range.
Dim dwb As Workbook: Set dwb = ThisWorkbook ' Workbooks("Destination.xlsm")
Dim dws As Worksheet: Set dws = dwb.Worksheets("New")
Dim drg As Range: Set drg = dws.Range("A1").CurrentRegion ' table
Dim dhrg As Range: Set dhrg = drg.Rows(1) ' header row
' This is the range the new data will be written to.
Set drg = drg.Resize(drCount).Offset(drg.Rows.Count)
' Determine the destination column indexes.
' Paste Columns
Dim dcIndexes() As Long: ReDim dcIndexes(0 To cUpper)
For c = 0 To cUpper
dcIndexes(c) = Application.Match(ColumnTitles(c), dhrg, 0)
Next c
' Write the data from the arrays of the array to the destination columns.
For c = 0 To cUpper
drg.Columns(dcIndexes(c)).Value = dJag(c)
Next c
' Inform.
MsgBox "Today's data transferred.", vbInformation
End Sub
I have range of years from 1994-2014 and for a reach corresponding company names values lies against each other (Output Sheet). There are sales figure for the respective company for each year which I used this formula (below) to get from the Sheet1 to output sheet.
Source Sheet/Sheet1
Output Sheet
=INDEX('Sheet1'!$E$5:$Y$685,MATCH(Output!B2,'Sheet1'!$D$5:$D$685,0),MATCH(Output!A2,'Sheet1'!$E$4:$Y$4,0))
I used two match formula as I wanted to validate company name as well as the year.
NOW, I want to check the values I retrieved from the above equation is an exact match/True to the source value. Thus, I tried using this formula but although the first IF logical is true, the second fails.
=IFS(Output!B2=INDEX('Sheet1'!$D$5:$D$685,MATCH(Output!B2,'Sheet1'!$D$5:$D$685,0)),"OK",C2=INDEX('Sheet1'!$E$5:$Y$685,MATCH(Output!B2,'Sheet1'!$D$5:$D$685,0),MATCH(Output!A2,'Sheet1'!$E$4:$Y$4,0)),"FINE")
I am looking for VBA code for the entire task at hand in case VBA makes it easier as I have huge dataset to perform the same procedure.
A VBA Unpivot
Copy the code into a standard module, e.g. Module1 of the workbook containing the two worksheets.
Carefully adjust the values in the constants section.
Both cell addresses refer to the first cells of the table headers.
You should give PowerQuery a try. It will take a few minutes once you get a hang of it. And it has a ton of options.
Option Explicit
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Unpivots a table range (has headers) to another worksheet.
' Calls: 'RefCurrentRegionBottomRight'.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub UnPivotData()
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "D4"
Const scCount As Long = 22
' Destination
Const dName As String = "Output"
Const dFirstCellAddress As String = "A1"
Dim dHeaders As Variant: dHeaders = VBA.Array("YEAR", "COMPANY", "WC01651")
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write from source range to source array.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim srg As Range
Set srg = RefCurrentRegionBottomRight(sfCell).Resize(, scCount)
Dim srCount As Long: srCount = srg.Rows.Count
Dim sData As Variant: sData = srg.Value
' Size destination array.
Dim dhUpper As Long: dhUpper = UBound(dHeaders)
Dim drCount As Long: drCount = (srCount - 1) * (scCount - 1) + 1
Dim dcCount As Long: dcCount = dhUpper + 1 ' zero- vs one-based
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write headers.
Dim dh As Long
For dh = 0 To dhUpper
dData(1, dh + 1) = dHeaders(dh)
Next dh
Dim dr As Long: dr = 1 ' headers already written
Dim sr As Long
Dim sc As Long
' Write data ('body').
For sr = 2 To srCount
For sc = 2 To scCount
dr = dr + 1 ' Note the 'PowerQuery' terms in parentheses:
dData(dr, 1) = sData(1, sc) ' write column labels (attributes)
dData(dr, 2) = sData(sr, 1) ' write row labels
dData(dr, 3) = sData(sr, sc) ' write values (values)
Next sc
Next sr
' Write from destination array to destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim dcrg As Range
Set dcrg = dfCell.Resize(dws.Rows.Count - dfCell.Row + 1, dcCount)
dcrg.ClearContents
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
MsgBox "Data transferred.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns a reference to the range starting with a given cell
' and ending with the last cell of its Current Region.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCurrentRegionBottomRight( _
ByVal FirstCellRange As Range) _
As Range
If FirstCellRange Is Nothing Then Exit Function
With FirstCellRange.Cells(1).CurrentRegion
Set RefCurrentRegionBottomRight = _
FirstCellRange.Resize(.Row + .Rows.Count - FirstCellRange.Row, _
.Column + .Columns.Count - FirstCellRange.Column)
End With
End Function
So I have this problem where if there is a value in a column, the row should be duplicated and copied to the next sheet. I will show a scenario to understand better.
This is sheet1
As you can see from the table above, there is a certain item name that doesn't have the three quantity columns. Some only have good quantity, some have both good and bad, and some have the three quantity. Now I want to copy this data to the other sheet with some modifications.
This should be the result in the next sheet:
As you can see, the data are duplicated based on the quantity columns if there is data or not. The status column is based on the quantity columns in sheet1. Status 0 is GOOD QTY, Status 1 is BAD QTY and Status 2 is VERY BAD QTY. This is my current code:
Set countsheet = ThisWorkbook.Sheets("Sheet1")
Set uploadsheet = ThisWorkbook.Sheets("Sheet2")
countsheet.Activate
countsheet.Range("B11", Range("F" & Rows.Count).End(xlUp)).Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
uploadsheet.Activate
uploadsheet.Range("B2").PasteSpecial xlPasteValues
I know this code only copies data from sheet1 to sheet2. How to modify this code and achieve the result above?
VBA Unpivot
Option Explicit
Sub UnpivotData()
' Needs the 'RefColumn' function.
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "B11" ' also Unique Column First Cell
Const sAddCount = 1 ' Additional Column i.e. 'ITEM NAME'
Const sAttrTitle As String = "STATUS"
Const sAttrRepsList As String = "0,1,2" ' Attribute Replacements List
Const sValueTitleAddress As String = "D10" ' i.e. QTY
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "B2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Reference the first column range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sfCell As Range: Set sfCell = sws.Range(sFirstCellAddress)
Dim sfcrg As Range: Set sfcrg = RefColumn(sfCell)
If sfcrg Is Nothing Then Exit Sub ' no data in the first (unique) column
' Reference the range and write it to an array.
Dim sAttrReps() As String: sAttrReps = Split(sAttrRepsList, ",")
Dim sAttrCount As Long: sAttrCount = UBound(sAttrReps) + 1
Dim scUniqueCount As Long: scUniqueCount = 1 + sAddCount
Dim scCount As Long: scCount = scUniqueCount + sAttrCount
Dim srg As Range: Set srg = sfcrg.Resize(, scCount)
Dim sData As Variant: sData = srg.Value
' Determine the destination size.
Dim srCount As Long: srCount = srg.Rows.Count
Dim svrg As Range
Set svrg = srg.Resize(srCount - 1, sAttrCount) _
.Offset(1, scUniqueCount)
Dim drCount As Long: drCount = Application.Count(svrg) + 1
Dim dcCount As Long: dcCount = scUniqueCount + 2
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
' Write the title row to the destination array.
Dim scu As Long ' Unique Columns
For scu = 1 To scUniqueCount
dData(1, scu) = sData(1, scu) ' Unique
Next scu
dData(1, scu) = sAttrTitle ' Attributes
dData(1, scu + 1) = sws.Range(sValueTitleAddress).Value ' Values
' Write the data rows to the destination array.
Dim dr As Long: dr = 1 ' first row already written
Dim sr As Long ' Rows
Dim sca As Long ' Attribute Columns
For sr = 2 To srCount ' first row already written
For sca = 1 To sAttrCount
If Len(CStr(sData(sr, sca + scUniqueCount))) > 0 Then
dr = dr + 1
For scu = 1 To scUniqueCount
dData(dr, scu) = sData(sr, scu) ' Unique
Next scu
dData(dr, scu) = sAttrReps(sca - 1) ' Attributes
dData(dr, scu + 1) = sData(sr, sca + scUniqueCount) ' Values
End If
Next sca
Next sr
' Write the destination array to the destination range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirstCellAddress)
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
drg.Value = dData
' Clear below the destination range.
With drg
Dim dcrg As Range
Set dcrg = .Resize(dws.Rows.Count - .Row - drCount + 1).Offset(drCount)
dcrg.Clear ' possibly just 'dcrg.ClearContents'
End With
MsgBox "Unpivot successful.", vbInformation, "Unpivot Data"
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
Below is the table I have
Client Accuracy Utilization TAT Volume
ABC 1 2 3 4
XYZ 5 2 4 3
PQR 2 2 5 2
The output should be something like below
Client Key Indicator
ABC Accuracy
ABC Utilization
XYZ Utilization
PQR Accuracy
PQR Utilization
PQR Volume
So for ratings less than 3 the client name and key indicator that has value less than 3 must get populated.
I tried using vlookup but the result is not as expected
Any insights how to achieve this.
If one has Office 365 we can do:
=LET(
clt,$A$2:$A$4,
ind,$B$1:$E$1,
rng,B2:E4,
sq,COLUMNS(rng)*ROWS(rng),
md,MOD(SEQUENCE(sq,,0),COLUMNS(rng))+1,
it,INT(SEQUENCE(sq,,1,1/COLUMNS(rng))),
FILTER(CHOOSE({1,2},INDEX(clt,it),INDEX(ind,,md)),INDEX(rng,it,md)<3,"")
)
Without Office 365, PowerQuery or VBA will be the best to normalize and filter the data.
Another Unpivot Flavor
Option Explicit
Sub UnPivot()
Const sName As String = "Sheet1"
Const sCriteria As Long = 3
Const sOperator As String = "<"
Const dName As String = "Sheet1"
Const dFirst As String = "G1"
Const dHeader As String = "Key Indicator"
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source Range ('srg').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
' Validate the Source Rows Count ('srCount')
' and Columns Count ('scCount').
Dim srCount As Long: srCount = srg.Rows.Count
If srCount < 2 Then Exit Sub ' only column labels, no data
Dim scCount As Long: scCount = srg.Columns.Count
If scCount < 2 Then Exit Sub ' only row labels, no data
' Define the Source Array ('sData').
Dim sData As Variant: sData = srg.Value
' Create a reference to the Source Values Range ('svrg').
Dim svrg As Range
Set svrg = srg.Resize(srCount - 1, scCount - 1).Offset(1, 1)
' Calculate the Destination Rows Count ('drCount').
Dim drCount As Long
drCount = Application.CountIf(svrg, sOperator & CStr(sCriteria)) + 1
If drCount = 1 Then Exit Sub
' Define the Destination Array ('dData').
Dim dData As Variant: ReDim dData(1 To drCount, 1 To 2)
' Write headers to the Destination Array.
dData(1, 1) = sData(1, 1)
dData(1, 2) = dHeader
' Declare variables.
Dim r As Long
Dim c As Long
Dim n As Long
' Write the data (row labels, column labels) to the Destination Array.
n = 1 ' because of headers
For r = 2 To srCount
For c = 2 To scCount
If sData(r, c) < sCriteria Then
n = n + 1
dData(n, 1) = sData(r, 1)
dData(n, 2) = sData(1, c)
End If
Next c
Next r
' Write the values from the Destination Array
' to the Destination Range ('drg').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
Dim drg As Range: Set drg = dfCell.Resize(drCount, 2)
drg.Value = dData
' Clear the contents of the Clear Range ('crg'), the range
' below the Destination Range.
Dim crg As Range
Set crg = drg.Resize(dws.Rows.Count - drg.Row - drCount + 1) _
.Offset(drCount)
crg.ClearContents
' Autofit the (entire) columns of the Destination Range.
drg.EntireColumn.AutoFit
' Save the changes.
wb.Save
End Sub