I'm pretty new to Excel VBA and I am currently trying to take data from multiple rows and transpose it into a single column. I know where the first cell of the data will begin, but that's all I know. Each row of data is a different sized row, and there can be a varying number of columns also.
So my current method is using a sort of transpose where I just select a very large range (in hopes that it captures all my data) and then transposing it. It does work, albeit pretty slow, and it also includes all the blanks in my range also.
Sub transpose()
Dim InputRange As Range
Dim OutputCell As Range
Set InputRange = Sheets("Sheet1").Range("P1:AC100")
'output will begin at this cell and continue down.
Set OutputCell = Sheets("Sheet1").Range("A1")
For Each cll In InputRange
OutputCell.Value = cll.Value
Set OutputCell = OutputCell.Offset(1, 0)
Next
End Sub
The current method isn't the worst, but I'm sure there are better methods that are quicker and ignore blanks. I'm not sure if an actual transpose is the best way, or perhaps using some sort of loop method. The data is usually contained within 200 rows, and 10 columns if that helps in deciding a method (maybe looping might be quick enough). Any help would be appreciated!
Edit
I have found a method of ignoring the blanks:
For Each cll In InputRange
If Not IsEmpty(cll.Value) Then
OutputCell.Value = cll.Value
Set OutputCell = OutputCell.Offset(1, 0)
End If
Next
This 'snake' method works fine for me.
Sub Snake()
Dim N As Long, i As Long, K As Long, j As Long
Dim sh1 As Worksheet, sh2 As Worksheet
K = 1
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
N = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To N
For j = 1 To Columns.Count
If sh1.Cells(i, j) <> "" Then
sh2.Cells(K, 1).Value = sh1.Cells(i, j).Value
K = K + 1
Else
Exit For
End If
Next j
Next i
End Sub
Before:
After:
One thing you could do is instead of looping the entire range just loop the SpecialCells.
Depending on what the content is of your inputRange then you can choose which XlCellType to use.
If it is just hardcoded values then xlCellTypeConstants would work fine for you.
Alternatively, you might be looking at formulas, in which case you would want to use xlCellTypeFormulas.You can also do a Union if you need both.
Here is an example using just xlCellTypeConstants
Sub transposes()
' Example just for hardcoded data
Dim inputRange As Range
Set inputRange = Sheets("Sheet1").Range("P1:AC100").SpecialCells(xlCellTypeConstants)
Dim outputCell As Range
Set outputCell = Sheets("Sheet1").Range("A1")
Dim cell As Range
For Each cell In inputRange
Dim offset As Long
outputCell.offset(offset).Value = cell.Value
offset = offset + 1
Next cell
End Sub
Option Explicit
Public Sub Range_2_Column_Skip_VbNUllString()
' Test Covered
'
Range_2_Column Cells(1, 1).CurrentRegion, _
Cells(1, 5), vbNullString
End Sub
Public Function Range_2_Column( _
ByVal r_Sour As Range, _
cell_Dest As Range, _
ByVal sKip As String)
' Test Covered
A2_2_Range A2_From_Coll( _
Coll_From_A2_Skip( _
A2_From_Range(r_Sour), sKip)), cell_Dest
End Function
Public Sub A2_2_Range( _
a2() As Variant, _
cell As Range)
' Test Covered
cell.Resize( _
UBound(a2), UBound(a2, 2)).Value = _
a2
End Sub
Public Function A2_From_Range( _
ByVal r As Range) _
As Variant()
' Test Covered
'
A2_From_Range = r.Value
End Function
Public Function Coll_From_A2_Skip( _
a2() As Variant, _
ByVal sKip As String) _
As Collection
' Test Covered
'
Dim coll As New Collection
Dim v As Variant
For Each v In a2
If v <> sKip Then
coll.Add v
End If
Next
Set Coll_From_A2_Skip = coll
End Function
Public Function A2_From_Coll( _
ByVal coll As Collection) _
As Variant()
' Test Covered
'
ReDim a2(1 To coll.Count, 1 To 1) As Variant
Dim v As Variant
Dim iCount As Long
iCount = 1
For Each v In coll
a2(iCount, 1) = v
iCount = iCount + 1
Next
A2_From_Coll = a2
End Function
Related
I have a dataset that is multiple strings and I want a unique count of the occurrences so I can review and refine my datasets. I've been unable to do this using formulas so went over to VBA, but hit a roadblock as I'm an amateur.
My data looks like this...
I want it to return this...
I've tried parsing it with text to columns, but in large datasets I have 60 columns with 100s of hits in my string. Therefore, transposing it then trying to get a count of uniques would be daunting.
Therefore, I was hoping VBA would help, but I can only seem to get a function and not with a Sub and Function to transpose then count. Something like below...
Sub Main()
Dim filename As String
Dim WorksheetName As String
Dim CellRange As String
Sheets.Add.Name = "ParsedOutput"
'==============================================================
' CHANGE THESE VALUES FOR YOUR SHEET
WorksheetName =
CellRange =
'==============================================================
' Get range
Dim Range
Set Range = ThisWorkbook.Worksheets(WorksheetName).Range(CellRange)
' Copy range to avoid overwrite
Range.Copy _
Destination:=ThisWorkbook.Worksheets("ParsedOutput").Range("A1")
' Get copied exclusions
Dim Copy
Set Copy = ThisWorkbook.Worksheets("ParsedOutput").Range("A:A")
' Parse and overwrite
Copy.TextToColumns _
Destination:=Range("A:A"), _
DataType:=xlDelimited, _
ConsecutiveDelimiter:=True, _
Comma:=True
End Sub
Option Explicit
Public Function Counter(InputRange As Range) As String
Dim CellValue As Variant, UniqueValues As New Collection
Application.Volatile
'For error Handling On Error Resume Next
'Looping through all the cell in the defined range For Each CellValue In InputRange
UniqueValues.Add CellValue, CStr(CellValue) ' add the unique item Next
'Returning the count of number of unique values CountUniqueValues = UniqueValues.Count
End Function
For the sake of simplicity, I will take minimal data to demostrate how to achieve what you want. Feel free to change the code to suit your needs.
Excel Sheet
Let's say our worksheet looks like this
Logic:
Find last row and last column as shown HERE and construct your range.
Store the values of that range in an array.
Loop through each item in that array and extract words based of , as a delimiter and store it in the collection. If the delimiter doesnt exist then store the entire word in the collection. To create a unique collection, we use On Error Resume Next as shown in the code below.
Based on the count of words in the collection, we create an 2D array for output. One part of the array will hold the word and the other part will hold the count of occurences.
Use .Find and .FindNext to count the occurence of a word in the range and then store it in array.
Write the array in one go to the relevant cell. For demonstration purpose, I will write to Column D
Code
I have commented the code so you should not have a problem understanding it but if you do then simply ask.
Option Explicit
Sub Sample()
Dim ws As Worksheet
'~~> Change this to relevant sheet
Set ws = Sheet1
Dim LastRow As Long, LastColumn As Long
Dim i As Long, j As Long, k As Long
Dim col As New Collection
Dim itm As Variant, myAr As Variant, tmpAr As Variant
Dim OutputAr() As String
Dim aCell As Range, bCell As Range, rng As Range
Dim countOfOccurences As Long
With ws
'~~> Find last row
LastRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
'~~> Find last column
LastColumn = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
'~~> Construct your range
Set rng = .Range(.Cells(1, 1), .Cells(LastRow, LastColumn))
'~~> Store the value in an array
myAr = rng.Value2
'~~> Create a unique collection
For i = LBound(myAr) To UBound(myAr)
For j = LBound(myAr) To UBound(myAr)
If Len(Trim(myAr(i, j))) <> 0 Then
'~~> Check data has "," delimiter
If InStr(1, myAr(i, j), ",") Then
tmpAr = Split(myAr(i, j), ",")
For k = LBound(tmpAr) To UBound(tmpAr)
On Error Resume Next
col.Add tmpAr(k), CStr(tmpAr(k))
On Error GoTo 0
Next k
Else
On Error Resume Next
col.Add myAr(i, j), CStr(myAr(i, j))
On Error GoTo 0
End If
End If
Next j
Next i
'~~> Count the number of items in the collection
i = col.Count
'~~> Create output array for storage
ReDim OutputAr(1 To i, 1 To 2)
i = 1
'~~> Loop through unique collection
For Each itm In col
OutputAr(i, 1) = Trim(itm)
countOfOccurences = 0
'~~> Use .Find and .Findnext to count for occurences
Set aCell = rng.Find(What:=OutputAr(i, 1), LookIn:=xlValues, _
Lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
Set bCell = aCell
countOfOccurences = countOfOccurences + 1
Do
Set aCell = rng.FindNext(After:=aCell)
If Not aCell Is Nothing Then
If aCell.Address = bCell.Address Then Exit Do
countOfOccurences = countOfOccurences + 1
Else
Exit Do
End If
Loop
End If
'~~> Store count in array
OutputAr(i, 2) = countOfOccurences
i = i + 1
Next itm
'~~> Output it to relevant cell
.Range("D1").Resize(UBound(OutputAr), 2).Value = OutputAr
End With
End Sub
Output
The following is a rough approach, and is open to tons of improvements, but should get you started.
Read the comments and adjust the code to fit your needs.
Option Explicit
Public Sub CountWordsInColumn()
' Adjust to set the sheet holding the data
Dim sourceSheet As Worksheet
Set sourceSheet = ThisWorkbook.Worksheets("DataSet")
' Adjust the column and row that contains the hits
Dim hitsColumn As String
Dim hitsStartRow As Long
Dim lastRow As Long
hitsColumn = "C"
hitsStartRow = 2
lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, hitsColumn).End(xlUp).Row
' Adjust the column that contains the hits
Dim sourceRange As Range
Set sourceRange = sourceSheet.Range(hitsColumn & hitsStartRow & ":" & hitsColumn & lastRow)
' Add values in each cell split by ,
Dim evalCell As Range
Dim splitValues As Variant
Dim counter As Long
ReDim splitValues(lastRow - hitsStartRow)
For Each evalCell In sourceRange
splitValues(counter) = Split(evalCell.Value, ",")
counter = counter + 1
Next evalCell
' Get all values into an array
Dim allValues As Variant
allValues = AddValuesToArray(splitValues)
' Get unique values into an array
Dim uniqueValues As Variant
uniqueValues = GetUniqueValues(allValues)
' Count duplicated values from unique array
Dim outputData As Variant
outputData = CountValuesInArray(uniqueValues, allValues)
' Add new sheet
Dim outputSheet As Worksheet
Set outputSheet = ThisWorkbook.Sheets.Add
PrintArrayToSheet outputSheet, outputData
End Sub
Private Function AddValuesToArray(ByVal myArray As Variant) As Variant
Dim counter As Long
Dim tempArray As Variant
Dim tempCounter As Long
Dim tempArrayCounter As Long
ReDim tempArray(0)
For counter = 0 To UBound(myArray)
For tempCounter = 0 To UBound(myArray(counter))
tempArray(tempArrayCounter) = myArray(counter)(tempCounter)
tempArrayCounter = tempArrayCounter + 1
ReDim Preserve tempArray(tempArrayCounter)
Next tempCounter
Next counter
ReDim Preserve tempArray(tempArrayCounter - 1)
AddValuesToArray = tempArray
End Function
Private Function GetUniqueValues(ByVal tempArray As Variant) As Variant
Dim tempCol As Collection
Set tempCol = New Collection
On Error Resume Next
Dim tempItem As Variant
For Each tempItem In tempArray
tempCol.Add tempItem, CStr(tempItem)
Next
On Error GoTo 0
Dim uniqueArray As Variant
Dim counter As Long
ReDim uniqueArray(tempCol.Count - 1)
For Each tempItem In tempCol
uniqueArray(counter) = tempCol.Item(counter + 1)
counter = counter + 1
Next tempItem
GetUniqueValues = uniqueArray
End Function
Function CountValuesInArray(ByVal uniqueArray As Variant, ByVal allValues As Variant) As Variant
Dim uniqueCounter As Long
Dim allValuesCounter As Long
Dim ocurrCounter As Long
Dim outputData As Variant
ReDim outputData(UBound(uniqueArray))
For uniqueCounter = 0 To UBound(uniqueArray)
For allValuesCounter = 0 To UBound(allValues)
If uniqueArray(uniqueCounter) = allValues(allValuesCounter) Then ocurrCounter = ocurrCounter + 1
Next allValuesCounter
' This is the output
Debug.Print uniqueArray(uniqueCounter), ocurrCounter
outputData(uniqueCounter) = Array(uniqueArray(uniqueCounter), ocurrCounter)
ocurrCounter = 0
Next uniqueCounter
CountValuesInArray = outputData
End Function
Private Sub PrintArrayToSheet(ByVal outputSheet As Worksheet, ByVal outputArray As Variant)
Dim counter As Long
For counter = 0 To UBound(outputArray)
outputSheet.Cells(counter + 1, 1).Value = outputArray(counter)(0)
outputSheet.Cells(counter + 1, 2).Value = outputArray(counter)(1)
Next counter
End Sub
Try,
It is convenient to use Dictionary to extract duplicate items.
Sub test()
Dim Ws As Worksheet, wsResult As Worksheet
Dim vDB, vSplit, v
Dim Dic As Object 'Scripting.Dictionary
Dim i As Long, n As Long
Set Dic = CreateObject("Scripting.Dictionary")
Set Ws = Sheets(1) 'ActiveSheet
vDB = Ws.Range("a1").CurrentRegion
For i = 2 To UBound(vDB, 1)
vSplit = Split(vDB(i, 3), ",")
For Each v In vSplit
If Dic.Exists(v) Then
Dic(v) = Dic.Item(v) + 1
Else
Dic.Add v, 1
End If
Next v
Next i
Set wsResult = Sheets(2)
n = Dic.Count
With wsResult
.UsedRange.Clear
.Range("a1").Resize(n) = WorksheetFunction.Transpose(Dic.Keys)
.Range("b1").Resize(n) = WorksheetFunction.Transpose(Dic.Items)
End With
End Sub
For all who won't use VBA.
Here a solution with PowerQuery:
Quelle = Excel.CurrentWorkbook(){[Name="tbl_Source"]}[Content],
Change_Type = Table.TransformColumnTypes(Quelle,{{"ID", Int64.Type}, {"Record", type text}, {"Hits", type text}}),
Split_Hits = Table.ExpandListColumn(Table.TransformColumns(Change_Type, {{"Hits", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "Hits"),
Clean_Spaces = Table.ReplaceValue(Split_Hits," ","",Replacer.ReplaceText,{"Hits"}),
Group_Rows = Table.Group(Clean_Spaces, {"Hits"}, {{"Count", each Table.RowCount(_), Int64.Type}})
in
Group_Rows
Approach simulating newer TextJoin and Unique functions
In order to complete the above solutions, I demonstrate an approach using
[1]a) a replacement of the TextJoin function (available since vers. 2019, MS 365 ~> the newer function code is commented out,btw),
[1]b) the FilterXML() function to get unique words (available since vers. 2013+) and
[3]a) a negative filtering to calculate results
Sub wordCounts()
'[0]define data range
With Sheet3
Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
Dim rng As Range: Set rng = .Range("A2:A" & lastRow)
End With
With WorksheetFunction
'[1]split a) available and b) unique words into arrays
' Dim words: words = Split(.TextJoin(",", True, rng), ",") ' (available vers. 2019+ or MS 365)
Dim words: words = Split(Join(.Transpose(rng), ","), ",") '
Dim uniques: uniques = UniqueXML(words) ' (already since vers. 2013+)
'[2]provide for calculation
'fill temporary array with words
Dim tmp: tmp = words
'declare cnt array for counting results
Dim cnt: ReDim cnt(0 To UBound(uniques), 0 To 0)
Dim old As Long: old = UBound(tmp) + 1 ' remember original size
'[3]get word counts
Dim elem
For Each elem In uniques
'a) filter out current elem
tmp = Filter(tmp, elem, False)
Dim curr As Long: curr = UBound(tmp) + 1
'b) count number of words (as difference of filtered tmp boundaries) ...
Dim n As Long: n = old - curr
' ... and remember latest array boundary
old = curr
'c) assign results to array cnt
Dim i As Long: cnt(i, 0) = n
i = i + 1 ' increment counter
Next elem
'[4]write word counts to target
rng.Offset(0, 2).Resize(UBound(uniques), 1) = .Transpose(uniques)
rng.Offset(0, 3).Resize(UBound(cnt), 1) = cnt
End With
End Sub
Help function UniqueXML()
Function UniqueXML(arr, Optional Delim As String = ",", Optional ZeroBased As Boolean = False)
' Purp: return unique list of array items
' Note: optional argument Delim defaulting to colon (",")
' Help: https://learn.microsoft.com/de-de/office/vba/api/excel.worksheetfunction.filterxml
' [1] get array data to xml node structure (including root element)
Dim wellformed As String
wellformed = "<root><i>" & Join(arr, "</i><i>") & "</i></root>"
' ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' [2] define XPath string searching unique item values
' Note: c.f. udf: https://stackoverflow.com/questions/58677041/vba-excel-how-to-display-non-equal-values-in-an-excel-array/58685756#58685756
' ------------------------------------------------
' //i ... all <i> node values after the DocumentElement
' [not( .=preceding::i)] ... only if not preceded by siblings of the same node value
' ------------------------------------------------
Dim myXPath As String
myXPath = "//i[not( .=preceding::i)]"
' [3] get "flat" 1-dim array (~> one-based!)
Dim tmp As Variant
tmp = Application.Transpose(WorksheetFunction.FilterXML(wellformed, myXPath))
' [3a] optional redim as zero-based array
If ZeroBased Then ReDim Preserve tmp(LBound(tmp) - 1 To UBound(tmp) - 1)
' [4] return function result
UniqueXML = tmp
End Function
I didn't understand the problem you have between sub or function; however, this is a function that counts the unique values in a range
Public Function Counter(InputRange As Variant) As Variant
Dim UniqueValues As New Collection
Dim Val As Variant
Dim Cell As Range
Dim I As Long
Application.Volatile
On Error Resume Next
For Each Cell In InputRange
Val = Split(Cell, ",")
If IsArray(Val) Then
For I = LBound(Val) To UBound(Val)
UniqueValues.Add Val(I), CStr(Val(I))
Next I
Else
UniqueValues.Add Val, CStr(Val)
End If
Next Cell
On Error GoTo 0
Counter = UniqueValues.Count
End Function
Okay so I am filtering a sheet ("Data") by a criteria:
Sub Filter_Offene()
Sheets("Data").Range("A:R").AutoFilter Field:=18, Criteria1:="WAHR"
End Sub
Then, I want to put the Filtered Table to populate a Listbox
My problem here is, that the amount of rows can vary, so I thought i could try and list where the filtered table "ends" by doing this cells.find routine:
Dim lRow As Long
Dim lCol As Long
lRow = ThisWorkbook.Sheets("Data").Cells.Find(What:="*", _
After:=Range("A1"), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
lRow = lRow + 1
This unfotunatly also counts "hidden" rows, so in my example it doesnt count 2 but 7..
I've used .Range.SpecialCells(xlCellTypeVisible)before, but It doesn't seem to function with the cells.find above.
Does someone have an Idea on how I can count the visible (=filtered) Table, and then put it in a Listbox?
EDIT: I populate the listbox (unfiltered) like this:
Dim lastrow As Long
With Sheets("Data")
lastrow = .Cells(.Rows.Count, "R").End(xlUp).Row
End With
With Offene_PZ_Form.Offene_PZ
.ColumnCount = 18
.ColumnWidths = "0;80;0;100;100;0;50;50;80;50;0;0;0;0;0;150;150;0"
.List = Sheets("Data").Range("A2:R" & lastrow).Value
End With
But this won't work with filtered Data.
Here is a fun little fact, Excel creates an hidden named range once you start filtering data. If you have continuous data (headers/rows) this would return your range without looking for it. Though since it seem to resemble UsedRange it may still be better to search your last used column and row and create your own Range variable to filter. For this exercise I'll leave it be. Furthermore, as indicated in the comments above, one can loop over Areas of visible cells. I'd recommend a check beforehand just to be safe that there is filtered data other than headers.
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Data")
Dim Area as Range
ws.Cells(1, 1).AutoFilter 18, "WAHR"
With ws.Range("_FilterDatabase")
If .SpecialCells(12).Count > .Columns.Count Then
For Each Area In .Offset(1).Resize(.Rows.Count - 1, .Columns.Count).SpecialCells(12).Areas
Debug.Print Area.Address 'Do something
Next
End If
End With
End Sub
The above works if no headers are missing obviously.
Here is a VBA code to populate UserForm1.ListBox1.List with filtered rows.
Thanks to #FaneDuru for improvements in the code edited as per his comments.
In Userform1 code
Private Sub UserForm_Initialize()
PopulateListBoxWithVisibleCells
End Sub
In Module
Sub PopulateListBoxWithVisibleCells()
Dim wb As Workbook, ws As Worksheet
Dim filtRng As Range, rw As Range
Dim i As Long, j As Long, x As Long, y As Long, k As Long, filtRngArr
i = 0: j = 0: x = 0: y = 0
Set wb = ThisWorkbook: Set ws = wb.Sheets("Sheet1")
Set filtRng = ws.UsedRange.Cells.SpecialCells(xlCellTypeVisible)
For Each Area In filtRng.Areas
x = x + Area.Rows.Count
Next
y = filtRng.Columns.Count
ReDim filtRngArr(1 To x, 1 To y)
For k = 1 To filtRng.Areas.Count
For Each rw In filtRng.Areas(k).Rows
i = i + 1
arr = rw.Value
For j = 1 To y
filtRngArr(i, j) = Split(Join(Application.Index(arr, 1, 0), "|"), "|")(j - 1)
Next
Next
Next
With UserForm1.ListBox1
.ColumnCount = y
.List = filtRngArr
End With
End Sub
We can also add more fields say row number like Split(rw.Row & "|" & Join(Application.Index(arr, 1, 0), "|"), "|")(j - 1) but for every such intended column increments, we need to increment value of y like y = filtRng.Columns.Count + 1
In order to find x (Number of rows) we don't need the first loop... Simply, x = filtRng.Cells.Count / filtRng.Columns.Count is enough
Try, please the next code, if you want to use a continuous (built) array. It is possible to build it from the discontinuous range address, too:
Sub Filter_Offene()
Dim sh As Worksheet, lastRow As Long, rngFilt As Range, arrFin As Variant
Set sh = Sheets("Data")
lastRow = sh.Range("R" & Rows.count).End(xlUp).Row
rngFilt.AutoFilter field:=18, Criteria1:="WAHR"
Set rngFilt = rngFilt.Offset(1).SpecialCells(xlCellTypeVisible)
arrFin = ContinuousArray(rngFilt, sh, "R:R")
With ComboBox1
.list = arrFin
.ListIndex = 0
End With
End Sub
Private Function ContinuousArray(rngFilt As Range, sh As Worksheet, colLet As String) As Variant
Dim arrFilt As Variant, El As Variant, arFin As Variant
Dim rowsNo As Long, k As Long, i As Long, j As Long, arrInt As Variant
arrFilt = Split(rngFilt.address, ",")' Obtain an array of areas addresses
'real number of rows of the visible cells range:
For Each El In arrFilt
rowsNo = rowsNo + Range(El).Rows.count
Next
'redim the final array at the number of rows
ReDim arFin(1 To rowsNo, 1 To rngFilt.Columns.count)
rowsNo = 1
For Each El In arrFilt 'Iterate between the areas addresses
rowsNo = Range(El).Rows.count 'number of rows of the area
arrInt = ActiveSheet.Range(El).value' put the area range in an array
For i = 1 To UBound(arrInt, 1) 'fill the final array
k = k + 1
For j = 1 To rngFilt.Columns.count
arFin(k, j) = arrInt(i, j)
Next j
Next i
Next
ContinuousArray = arFin
End Function
I am trying to add/remove rows to a table in excel automatically dependent on the value of a cell in another table on a different sheet.
For example;
On a seperate sheet I have one table with the following. This table contains all projects regardless of project outcome.
And then on another sheet I have a table containing all the entries that have been deemed a success.
I am trying to collate all projects that have been identified as a success to the above table. However, If I was to change Project1 to a Fail on the first table Project1 must be removed from the bottom table.
I have tried if statements but I can't seem to get the logic right. Would this have to be achieved through the use of a macro?
Any help would be greatly appreciated.
A VBA Solution
The code runs automatically, you don't have to run anything. The code
will run when you change the criteria values (Success, Fail). Keep in mind
that the criteria is case sensitive.
Copy the following code into the sheet code of the source sheet
e.g. Sheet1 and carefully adjust the 5 constants to fit your needs.
Sheet Code
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Const FirstRow As Long = 2 ' Source/Target First Row Number
Const Cols As String = "A:G" ' Source/Target Columns Range Address
Const CritCol As Long = 4 ' Criteria Column
' Note: If CritCol = n then it presents the n-th column of Columns Range,
' and not the n-th column of the worksheet.
Const Criteria = "Success" ' Criteria
Const TargetName = "Sheet2" ' Target Worksheet Name
Dim SourceColumns As Range
Set SourceColumns = Me.Columns(Cols)
Dim CriteriaColumn As Long
CriteriaColumn = getNthColumn(Me, SourceColumns.Address, CritCol)
If CriteriaColumn = 0 Then Exit Sub
If Intersect(Me.Columns(CriteriaColumn), Target) Is Nothing Then Exit Sub
Dim CriteriaRange As Range
Set CriteriaRange = getColumnRange(Me, CriteriaColumn, FirstRow)
If Not Intersect(CriteriaRange, Target) Is Nothing Then
Dim TargetSheet As Worksheet
Set TargetSheet = ThisWorkbook.Worksheets(TargetName)
transferData SourceColumns, CriteriaRange, CritCol, Criteria, _
FirstRow, TargetSheet
End If
End Sub
Copy the following code into a standard module e.g. Module1.
Nothing to change here.
Module Code
Option Explicit
Function getColumnRange(Sheet As Worksheet, _
ByVal ColumnNumberOrLetter As Variant, _
Optional ByVal FirstRow As Long = 1) As Range
Dim rng As Range
Set rng = Sheet.Columns(ColumnNumberOrLetter) _
.Find("*", , xlFormulas, , , xlPrevious)
If rng Is Nothing Then Exit Function ' No data in whole column.
If rng.Row < FirstRow Then Exit Function ' No data in and below first cell.
Set getColumnRange = Sheet.Range(Sheet.Cells(FirstRow, rng.Column), rng)
End Function
Function getNthColumn(Sheet As Worksheet, ByVal RangeAddress As String, _
Optional ByVal NthColumn As Long = 1) As Long
Dim rng As Range
Set rng = Sheet.Columns(RangeAddress)
If rng Is Nothing Then Exit Function
If rng.Columns.Count < NthColumn Then Exit Function
getNthColumn = rng.Column + NthColumn - 1
End Function
Sub transferData(SourceColumns As Range, CriteriaColumnRange As Range, _
CriteriaColumn As Long, Criteria As Variant, FirstRow As Long, _
TargetSheet As Worksheet)
Dim NoR As Long
NoR = Application.WorksheetFunction.CountIf(CriteriaColumnRange, Criteria)
Dim Source As Variant
Source = Intersect(SourceColumns, CriteriaColumnRange.Rows.EntireRow)
Dim Target As Variant
Dim i As Long, j As Long, k As Long
ReDim Target(1 To NoR, 1 To UBound(Source, 2))
For i = 1 To UBound(Source)
If Source(i, CriteriaColumn) = Criteria Then
k = k + 1
For j = 1 To UBound(Source, 2)
Target(k, j) = Source(i, j)
Next j
End If
Next i
Erase Source
With TargetSheet
.Range(SourceColumns.Rows(FirstRow).Address).Resize( _
.Rows.Count - FirstRow + 1).ClearContents
.Range(SourceColumns.Rows(FirstRow).Address).Resize(k) = Target
End With
End Sub
I have this sample table.
What I am trying to do is to get all the cell values in all colored cells and transpose them to another worksheet.
I have trouble with the code below to add and set those ranges together so that I can transpose all of them in a ROW in the other worksheet. I have started with the code below
Sub AddRanges()
Dim inRange As Range, inRangeValues() As Variant, outRangeValues() As Variant
Dim finalRow As Long
Dim inRange As Range
Set inRange = Sheet1.Range("A1:A6", "C1:C6", C10:C14) 'I think i got this wrong; Error Type Mismatch
inRangeValues() = inRange.Value 'generate 2d array
outRangeValues = Application.Transpose(inRangeValues)
With Sheet2
finalRow = .Cells(Rows.Count, 1).End(xlUp).Row 'find last row
If inRange.Columns.Count > 1 Then '2d array for output
.Cells(finalRow + 1, 1).Resize(UBound(outRangeValues, 1), UBound(outRangeValues, 2)) = outRangeValues 'Resize according to output array dimensions
Else '1D array for output
.Cells(finalRow + 1, 1).Resize(1, UBound(outRangeValues, 1)) = outRangeValues
End If
End With
End sub
In this example, what is the best approach to combine these ranges so I can transpose them as a ROW? Thanks.
Your code has major problems due to:
Double declaration of inRange
Wrong syntax for Set inRange the entire address needs to be enclosed in a single pair of quotes
Try Set inRange = Range("a1:a6, c1:c6, c10:c14")
Wrong method of reading into an array
When you have a range that consists of multiple areas, you have to convert each area separately.
Then you can create a 1-D array from this depending on the order you wish to have these elements, and write it wherever you want.
For example:
Option Explicit
Sub test()
Dim inRange As Range, inRangeValues As Variant, outRangeValues As Variant
Dim finalRow As Long
Dim I As Long, J As Long, V As Variant, L As Long
Dim lCols As Long
Set inRange = Range("a1:a6, c1:c6, c10:c14")
ReDim inRangeValues(1 To inRange.Areas.Count)
For I = 1 To inRange.Areas.Count
inRangeValues(I) = inRange.Areas(I)
Next I
'how many columns?
lCols = 0
For I = 1 To UBound(inRangeValues, 1)
lCols = lCols + UBound(inRangeValues(I), 1)
Next I
ReDim outRangeValues(1 To lCols)
L = 0
For I = 1 To UBound(inRangeValues, 1)
For J = 1 To UBound(inRangeValues(I), 1)
L = L + 1
outRangeValues(L) = inRangeValues(I)(J, 1)
Next J
Next I
Stop
' enter some code to write the results where you want
' below is just throwaway for proof of concept
Range("f20").Resize(columnsize:=UBound(outRangeValues)).Value = outRangeValues
End Sub
Given your input, the above code would create output like:
You are correct that your code is wrong where you highlight. Try a union. From there, it should be pretty basic to just loop through your range and put them wherever you want in the Sheet2 spreadsheet. See if the below does what you need.
Sub AddRanges()
Dim inRange As Range, acell As Range, aCounter As Long
Const startAddress As String = "A1"
Set inRange = Union(Sheet1.Range("A1:A6"), Sheet1.Range("C1:C6"), Sheet1.Range("C10:C14"))
For Each acell In inRange.Cells
If Not IsEmpty(acell) Then
finalRow = sheet2.Cells(Rows.Count, 1).End(xlUp).Row + 1 'find last row
sheet2.Cells(finalRow, 1).Value = acell.Value
End If
Next acell
End Sub
Check it out.
Sub RngAreaTransps()
Dim RangeArea As Range, LstRw As Long
Dim sh As Worksheet, ws As Worksheet
Dim col As Long, InRange As Range
Set sh = Sheets(1)
Set ws = Sheets(2)
LstRw = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
With sh
Set InRange = .Range("A1:A6, C1:C6, C10:C14")
For Each RangeArea In InRange.Areas
With ws
col = .Cells(LstRw, .Columns.Count).End(xlToLeft).Column
If col <> 1 Then col = col + 1
RangeArea.SpecialCells(xlCellTypeConstants).Copy
.Cells(LstRw, col).PasteSpecial Transpose:=True
End With
Next RangeArea
End With
Application.CutCopyMode = False
End Sub
I have a large table filled with data. What I want to do is check wether a set of data already exists within this table. I have inserted the data I am looking for in a separate worksheet. The Range with the table items I am looking for I called "SearchedData" and the Area where I am checking wether it holds the data I am looking for I called "SearchArea".
My code only shows me the data would exist but in the worksheet I am working on it doesn't so there must be something wrong with my code. Any help on this would be very much appreciated!
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
SearchArea = ThisWorkbook.Worksheets("Tabelle1").Range("A:E").Value
If SearchArea = SearchedData Then
MsgBox ("Searched Data already exists")
Else: MsgBox ("Searched Data is missing")
End If
End Sub
This is a way more complicated to solve.
Imagine Tabelle2 as following:
And Tabelle1 as following:
I suggest to use the Range.Find method to find the first occurenc of the first cells data here this is represented by 11. And then check if the rest of the data is right/below there too. Do this in a loop until all occurences are checked.
So in Tabelle1 the yellow areas will be ckecked but the only full match is at A14:E17 which will be considered as duplicate.
Option Explicit
Public Sub CheckIfDataExists()
Dim wsSearch As Worksheet
Set wsSearch = ThisWorkbook.Worksheets("Tabelle1")
Dim SearchRange As Range
Set SearchRange = wsSearch.Range("A1", wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp))
Dim SearchData() As Variant 'data array
SearchData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
Dim FoundData() As Variant
'remember first find to prevent endless loop
Dim FirstFoundAt As Range
Set FirstFoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=SearchRange.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FirstFoundAt Is Nothing Then
Dim FoundAt As Range
Set FoundAt = FirstFoundAt
Do
Set FoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=FoundAt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FoundAt Is Nothing Then
FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Select
FoundData = FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Value
If AreArraysEqual(SearchData, FoundData) Then
MsgBox "data found at " & FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Address
Exit Sub
End If
End If
Loop Until FoundAt Is Nothing Or FirstFoundAt.Row >= FoundAt.Row
End If
MsgBox "data not found"
End Sub
Private Function AreArraysEqual(Arr1 As Variant, Arr2 As Variant) As Boolean
Dim iRow As Long, iCol As Long
'default
AreArraysEqual = True
For iRow = LBound(Arr1, 1) To UBound(Arr1, 1)
For iCol = LBound(Arr1, 2) To UBound(Arr1, 2)
If Arr1(iRow, iCol) <> Arr2(iRow, iCol) Then
AreArraysEqual = False
Exit Function
End If
Next iCol
Next iRow
End Function
I believe this code will do what you want reasonably fast.
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
Dim LookFor() As String
Dim LookIn() As String
Dim R As Long, C As Long
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
LookFor = MergedRows(SearchedData)
With ThisWorkbook.Worksheets("Tabelle1")
SearchArea = .Range(.Cells(2, 1), .Cells(.Rows.Count, 5).End(xlUp)).Value
End With
LookIn = MergedRows(SearchArea)
For R = 1 To UBound(LookIn)
If LookIn(R) = LookFor(1) Then
If R < UBound(LookIn) - 2 Then
For C = 2 To UBound(LookFor)
If LookIn(R + C - 1) <> LookFor(C) Then Exit For
Next C
If C > UBound(LookFor) Then
MsgBox "Match found in Row " & R
Exit For
End If
End If
End If
Next R
End Sub
Private Function MergedRows(RngVal As Variant) As String()
Dim Fun() As String
Dim R As Long, C As Long
ReDim Fun(1 To UBound(RngVal))
For R = 1 To UBound(RngVal)
For C = 1 To UBound(RngVal, 2)
Fun(R) = Fun(R) & "," & RngVal(R, C)
Next C
Next R
MergedRows = Fun
End Function
The code creates merged strings of 5 cells of both the SearchedData and the SearchArea data. This job is done by the Function MergedRows. In the process the SearchedData turn into array LookFor(1 To 3) and LookIn(1 To LastRow). Next the first element (representing a row) of LookFor is compared to each element (representing a row) of LookIn. If a match is found the other two rows are also compared. When all three elements (rows) match a message is issued and the search is terminated.