Could help me merge these two modules, so I can use them more than only one time?
First module:
Private Sub UserForm_Initialize()
Dim ultimaLin As Long, area As New Collection
Dim Value As Variant, temp() As Variant
On Error Resume Next
ultimaLin = Sheets("DBTemp").Range("A" & Rows.Count).End(xlUp).Row
temp = Sheets("DBTemp").Range("A2:A" & ultimaLin).Value
For Each Value In temp
If Len(Value) > 0 Then area.Add Value, CStr(Value)
Next Value
For Each Value In area
titulo_livro.AddItem Value
Next Value
Set area = Nothing
End Sub
Second module:
Private Sub UserForm_Initialize()
Dim ultimaLin As Long, area As New Collection
Dim Value As Variant, temp() As Variant
On Error Resume Next
ultimaLin = Sheets("DBTemp").Range("B" & Rows.Count).End(xlUp).Row
temp = Sheets("DBTemp").Range("B2:B" & ultimaLin).Value
For Each Value In temp
If Len(Value) > 0 Then area.Add Value, CStr(Value)
Next Value
For Each Value In area
autor_livro.AddItem Value
Next Value
Set area = Nothing
End Sub
As you can see it, they are basically the same thing, but in the second one I want to reproduce the obtained result in another range.
Thanks!
You can factor out the common parts of the code into re-usable methods.
Example Form module code:
Private Sub UserForm_Initialize()
With ThisWorkbook.Sheets("DBTemp")
FillFromRange .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row), _
titulo_livro
End With
End Sub
In a regular module:
Sub FillFromRange(rng As Range, ctrl As Object)
Dim v
For Each v In UniquesFromRange(rng)
ctrl.AddItem v
Next v
End Sub
Function UniquesFromRange(rng As Range)
Dim col As New Collection, data, v
data = rng.Value
For Each v In data
If Len(v) > 0 Then
On Error Resume Next
col.Add v, CStr(v)
On Error GoTo 0
End If
Next v
Set UniquesFromRange = col
End Function
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
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'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
I am new to macros, please help me in the below scenario issue
Scenario
Compare two excel sheets columns(Source Sheet & Target Sheet) and put the reult in a different sheet(Result Sheet).
NOTE - Columns selection from source and target are dynamic
Input the Colum names which you want to include in Result sheet in addition to Source & target Column. ( e.g include column B, C, D , F (from source sheet) also in result sheet.
Issue
Below is my script,the issue is while pasting the dynamic selected column from source to result sheet it is pasting the data in column which are given input in source.
Example - while pasting the C,G,F from source to result sheet it is pasting the data in columns C,G,F of result instead pasting in the next empty column(B,C,D).
In the below script "Worksheets("Result").Cells(Rownum, ch) = Column_source_value" is causing this issue, please help me how i need to change Cells parameters
Code
Dim ws1lastrow As Long, ws2lastrow As Long, ws1lastcolumn As Integer, ws2lastcolumn As Integer
Dim maxRow As Integer, maxColumn As Integer
Dim i As Integer, j As Integer, k As Integer, x As Long, Column_source As String, Column_target As String
Dim sourceValue As String
Dim targetvalue As String
Dim addsourcecolvalue As String, ch As Variant, AddColumn_source_num As String, AddColumn_source_value As String
Dim addsourceValue() As String
Sub Compare()
CompareWorksheets Worksheets("Source"), Worksheets("Target")
End Sub
Sub CompareWorksheets(ws1 As Worksheet, ws2 As Worksheet)
sourceValue = Sheets("Source").TextBox1.Value
targetvalue = Sheets("Source").TextBox2.Value
addsourcecolvalue = Sheets("Source").TextBox3.Value
With ws1.UsedRange
ws1lastrow = .Rows.Count
ws1lastcolumn = .Columns.Count
End With
With ws2.UsedRange
ws2lastrow = .Rows.Count
ws2lastcolumn = .Columns.Count
End With
maxRow = ws1lastrow
maxColumn = ws1lastcolumn
For i = 1 To ws1lastrow
For j = 1 To ws2lastrow
Column_source_num = sourceValue & i
Column_target_num = targetvalue & j
Column_source_value = Worksheets("Source").Range(Column_source_num).Value
Column_target_value = Worksheets("Target").Range(Column_target_num).Value
If Column_source_value = Column_target_value Then
Sheets("Source").Cells.Find(What:=Column_source_value, LookAt:=xlWhole, MatchCase:=False, SearchFormat:=False).Activate
Dim Rownum As String
Rownum = ActiveCell.Row
Worksheets("Result").Cells(i, 1) = Column_source_value
splitsourcecloumn (Rownum)
End If
Next j
Next i
End Sub
Function splitsourcecloumn(Rownum)
addsourceValue() = Split(addsourcecolvalue, ",")
For Each ch In addsourceValue()
Column_source_num = ch & Rownum
Column_source_value = Worksheets("Source").Range(Column_source_num).Value
Worksheets("Result").Cells(Rownum, ch) = Column_source_value
Next ch
End Function
Try using this function to find the first unused column.
Public Function GetLastColumn() As Long
If WorksheetFunction.CountA(Cells) > 0 Then
GetLastColumn = Cells.Find(What:="*", _
After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
End If
End Function
I hope this helps!