Comparing 2 Pair Data with Loop in Ms Excel VBA - excel

Is anyone can help me, pls take a look at the picture i attached.
I want to compare 2 pair of data from 2 different excel file, Station (left file column B) with Station (right file column A) AND Time (left file row 1) with Tendancy (right file Column F).
The left file is the report that im about to finished, the right file is the reference data. If the station and the time data is match each other, it will filled with "1", if not it will stay empty.
The data will start filling from cell C2 until Z32. Im stuck with FOR and IF looping i used. And here's the example:
Cell C2 will filed with "1" bcs there is station 2000001 (cell A2) at 00UTC (cell F2) on the right file.
Cell E2 will stay empty bcs there is station 2000001 BUT NOT at 02UTC on the right file.
Cell C3 will stay empty bcs there is station 2000002 BUT NOT at 00UTC on the right file.
Dim countSM As Long
Dim countSS As Long
Dim countWM As Long
Dim countWS As Long
Dim resultCol As Long
Dim resultRow As Long
Dim lastSM As Long
Dim lastSS As Long
Dim lastWM As Long
Dim lastWS As Long
Dim lastRCol As Long
Dim lastRRow As Long
lastSM = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
lastSS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastWM = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastWS = wb2.Sheets("Worksheet").Cells(Rows.count, 1).End(xlUp).Row
lastRCol = wb1.Sheets("Sheet1").Cells(1, Columns.count).End(xlToLeft).Column
lastRRow = wb1.Sheets("Sheet1").Cells(Rows.count, 1).End(xlUp).Row
For countSM = 2 To lastWM
For countSS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(countSM, "B") = wb2.Sheets("Worksheet").Cells(countSS, "A") Then
For countWM = 3 To lastWM
For countWS = 2 To lastWS
If wb1.Sheets("Sheet1").Cells(1, countWM) = wb2.Sheets("Worksheet").Cells(countWS, "F") Then
For resultRow = 2 To lastRRow
For resultCol = 3 To lastRCol
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = "1"
Next resultCol
Next resultRow
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(1, countWM) <> wb2.Sheets("Worksheet").Cells(countWS, "F") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countWM
End If
Next countSS
ElseIf wb1.Sheets("Sheet1").Cells(countSM, "B") <> wb2.Sheets("Worksheet").Cells(countSS, "A") Then
wb1.Sheets("Sheet1").Cells(resultRow, resultCol) = ""
Next countSM
End If

I made a code that may work for you. Just count how many rows got the station and UTC value you want to check. If the answer is zero, leave the cell empty. If not, then return 1.
My code is designed on same workbook but it can be adapted yo work with 2 different workbooks easily.
My fake dataset:
My code:
Sub test()
'<------>
'
'
'
'
'YOUR CODE TO OPEN BOTH FILES
'
'
'
'<---->
Dim LeftSheet As Worksheet
Dim RightSheet As Worksheet
Dim MyData As Range 'range to store the data (right file)
Dim LR As Long 'Last row of left file, column Station
Dim LC As Long 'Lastcolumn of left file, (whatever UTC it is)
Dim i As Long
Dim zz As Long
Dim MiF As WorksheetFunction
Set MiF = WorksheetFunction
Dim MyStation As String
Dim MyUTC As String
'Probably you'll need just to adjust references to worksheets from different workbooks
Set LeftSheet = ThisWorkbook.Worksheets("Destiny")
Set RightSheet = ThisWorkbook.Worksheets("Source")
'we store all data into array
Set MyData = RightSheet.Range("A1").CurrentRegion
'data starts at index 2, and we want data from columns 1 and 6 on the range
'Columns 1 and 6 mean columns A and F
'I guess maybe you'll need to adapt this too.
With LeftSheet
LR = .Range("B" & .Rows.Count).End(xlUp).Row
LC = .Cells(1, .Columns.Count).End(xlToLeft).Column
'we count how many rows got the station and tendancy value (intersection) on the right file
' if the count is 0, do nothing. If not zero, return 1 on the cell
'our references will be always at column 2 and row 1
For i = 2 To LR Step 1 'we start at row 2 on left file
MyStation = .Range("B" & i).Value
For zz = 3 To LC Step 1 'we start at column 3, that means column C
MyUTC = .Cells(1, zz).Value
If MiF.CountIfs(MyData.Columns(1), MyStation, MyData.Columns(6), MyUTC) <> 0 Then .Cells(i, zz).Value = 1
Next zz
Next i
End With
'clean variables
Set MyData = Nothing
Set LeftSheet = Nothing
Set RightSheet = Nothing
End Sub
Output after executing code:

Give this solution a try:
Option Explicit
Private Type TWorksheetData
WrkSheet As Worksheet
LastRow As Long
LastColumn As Long
End Type
Sub CopyCompare()
'Organize the variables by referenced worksheet
Dim worksheetData As TWorksheetData
Dim sheet1Data As TWorksheetData
'your solution will provide separate Workbooks for the code below
'ActiveWorkbook (in my case) had both worksheets in order to develop the solution
sheet1Data = SetupWorksheetData(Application.ActiveWorkbook, "Sheet1", sheet1Data)
worksheetData = SetupWorksheetData(Application.ActiveWorkbook, "Worksheet", worksheetData)
Dim refData As Dictionary
Set refData = New Dictionary
'Load the reference data (key = station, value = collection of UTCs)
Dim station As Long
Dim countRow As Long
For countRow = 2 To worksheetData.LastRow
station = CLng(worksheetData.WrkSheet.Range("A" & CStr(countRow)).Value)
If Not refData.Exists(station) Then
refData.Add station, New Collection
End If
refData(station).Add worksheetData.WrkSheet.Range("F" & CStr(countRow)).Value
Next countRow
'Load the UTC header columns from Sheet1
Dim outputMap As Dictionary '(key = UTCXX, value = column Number)
Set outputMap = LoadUTCHeaderColumns(sheet1Data)
'Operate on the Sheet1 data to set the value
For countRow = 2 To sheet1Data.LastRow
station = CLng(sheet1Data.WrkSheet.Range("B" & CStr(countRow)).Value)
Dim utcRef As Variant
If refData.Exists(station) Then
Dim utc As Variant
For Each utc In refData(station)
If InputSheetHasUTCEntry(utc, outputMap) Then
sheet1Data.WrkSheet.Cells(countRow, outputMap(utc)) = "1"
End If
Next
End If
Next countRow
End Sub
Private Function InputSheetHasUTCEntry(ByVal utc As String, ByVal outputMap As Dictionary) As Boolean
InputSheetHasUTCEntry = False
Dim utcRef As Variant
For Each utcRef In outputMap.Keys
If utc = utcRef Then
InputSheetHasUTCEntry = True
Exit Function
End If
Next utcRef
End Function
Private Function LoadUTCHeaderColumns(ByRef sheetData As TWorksheetData) As Dictionary
Set LoadUTCHeaderColumns = New Dictionary
Dim columnHeader As String
Dim outputCol As Long
For outputCol = 1 To sheetData.LastColumn
columnHeader = sheetData.WrkSheet.Cells(1, outputCol).Value
If InStr(columnHeader, "UTC") > 0 Then
LoadUTCHeaderColumns.Add columnHeader, outputCol
End If
Next outputCol
End Function
Private Function SetupWorksheetData(ByVal wb As Workbook, ByVal sheetName As String, ByRef wrksheetData As TWorksheetData) As TWorksheetData
SetupWorksheetData = wrksheetData
Set SetupWorksheetData.WrkSheet = wb.Sheets(sheetName)
SetupWorksheetData.LastRow = SetupWorksheetData.WrkSheet.Cells(Rows.Count, 1).End(xlUp).Row
SetupWorksheetData.LastColumn = SetupWorksheetData.WrkSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Solution comments:
Loads static reference data from from sheet Worksheet (recommend a different sheet name)
Loads static column number information from Sheet1
There are lots of variables holding similar data for each worksheet used. This indicates an opportunity for using a UserDefinedType (TWorksheetData in this case). This organizes and reduces the number of variables to declare and track.
#1 and #2 uses a Dictionary to retain and correlate static information (requires adding a reference to the Microsoft Scripting Runtime).
Other comments:
(Best Practice) Always declare Option Explicit at the top of modules. Forces all variables used to be declared.
(Best Practice) Don't Repeat Yourself (DRY) - there is a lot of repeated expressions in the original code. This is especially important with Strings. More could be done with the solution provided, but (for example) you will notice that the worksheet name strings only appear once.

Related

In VBA find the max number of times a character appears in a single cell out of a range of cells

Before I start, I just want to thank every contributor ahead of time. I've only posted one question before, and I was amazed at how quickly I got responses and how much I learned after studying the solution. I'm hoping I will have enough reputation points soon to start upvoting good solutions I find here.
Anyways, what I'm trying to do is return one number, and that number is the maximum number of names that appear in a single cell of a worksheet column. Each cell in that column can have any number of names in it. Each name is delimited by a pipe "|", so I count the pipes and then add one to get the number of names in each cell. For example: Cell value is "Bob | Jon | Larry" = 2pipes +1 = 3 names.
My code below works, but I need to do this on tens of thousands of records. I don't think my solution is a good or efficient way to do it (tell me if I'm wrong). So my questions are:
Is there a better way to accomplish this, such as without looping through every cell in the range?
If there isn't a totally different approach to this, how can I avoid actually printing the name counts in cells in a new column? Could I store these values in an array and calculate the max of the array? (maybe there is already a thread on this topic you could point me to?)
Sub charCnt()
Application.ScreenUpdating = True
Application.Calculation = xlCalculationManual
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = Worksheets("Leasing")
Dim vRange As Variant
Dim iCharCnt As Integer
Dim iRows As Integer
Dim i As Integer
Dim iMax As Integer
Const sFindChar As String = "|"
iRows = ws.Cells(Rows.Count, "A").End(xlUp).Row 'count number of rows
For i = 1 To iRows
vRange = Cells(i, "O") 'column O has the names
iCharCnt = Len(vRange) - Len(Replace(vRange, sFindChar, "")) 'find number of | in single cell.
ws.Cells(i, "W") = iCharCnt 'column W is an empty column I use to store the name counts
Next i
iMax = Application.WorksheetFunction.Max(Range("W:W")) + 1 'return max from column W
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
Max Number of Substrings
Option Explicit
Sub charCount()
Const cCol As String = "O"
Const fRow As Long = 1
Const Delimiter As String = "|"
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("Leasing")
Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, cCol).End(xlUp).Row
Dim rg As Range: Set rg = ws.Cells(fRow, cCol).Resize(lRow - fRow + 1)
Dim Data As Variant: Data = rg.Value
Dim i As Long
For i = 1 To UBound(Data, 1)
Data(i, 1) = Len(Data(i, 1)) - Len(Replace(Data(i, 1), Delimiter, ""))
Next i
Dim iMax As Long: iMax = Application.Max(Data) + 1
MsgBox ("Max number of names in one cell is " & iMax) ' show result
End Sub
A close-to-formula approach
Combining worksheet functions CountA() and FilterXML() allows to get all substring counts separated by the pipe character |:
Sub CountSubstrings(StartCell As Range, TargetRng As Range)
'Purp.: count items separated by pipes
'Meth.: via worksheetfunction FILTERXML()
'Note: assumes target in same sheet as StartCell (could be changed easily)
'a) enter formula into entire target range
Const PATTERN$ = _
"=IF(LEN($),COUNTA(FILTERXML(""<t><s>""&SUBSTITUTE($,""|"",""</s><s>"")&""</s></t>"",""//s"")),0)"
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Parent.Name & "!" & StartCell.Address(False, False))
'b) optional overwriting of formulae
'TargetRng = TargetRng.Value
'c) display maximum result
MsgBox Application.Max(TargetRng)
End Sub
Hint: You can even shorten code as follows if you want to include the fully qualified workbook + worksheet reference in the formula assignment. Just use the additional argument External:=True in .Address (resulting e.g. in something like '[Test.xlsm]Sheet1'!A2):
TargetRng.Formula2 = Replace(PATTERN, _
"$", StartCell.Address(False, False, External:=True))
Possible Example call
With Sheet1
CountSubstrings .Range("A2"), .Range("D2:D5")
End With
Further link
C.f. JvdV's encyclopaedia-like site demonstrating the various possibilities to use FilterXML()
Brilliant answer by VBasic2008. I thought I would look at it purely as a coding exercise for myself. Alternative below provided for interest only.
Option Explicit
Sub CountMaxNames()
Dim arr1(), i, j, count As Long, tally As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("leasing")
arr1 = ws.Range("O1:O" & ws.Range("O" & Rows.count).End(xlUp).Row)
count = 0: tally = 0
For Each i In arr1
For j = 1 To Len(i)
If Mid(i, j, 1) = "|" Then count = count + 1
Next j
count = count + 1
If count >= tally Then tally = count
count = 0
Next i
MsgBox "Maximum number of names in one cell is " & tally
End Sub

If statement for two values for large set of data

I struggle with VBA and have spent a few days trying to find a solution to this problem. Essentially, I have two spreadsheets with large sets of data. Column K of "Design Mods" worksheet contains the same types of values as Column C of the "Output" Worksheet. I've been trying to get my script to do the following:
1. for each cell in column k of "Design Mods", check if there is a matching cell in column c of the "output" spreadsheet
2. if a match is found, then populate the cell in "Design Mods" to columns over with the information from column b of "Output"
Because of my lack of experience, I've only been able to setup the script below which only checks and pulls correctly for one cell.
I need it to check each cell against a range of other cells.
Any help/guidance would be very much appreciated.
Thank you very much!
Sub MatchValue_Test()
'Routine is meant to populate columns "Design Mods" Spreadsheet with affected calculations from the "Output" Spreadsheet
'Variables below refer to Design Mods spreadsheet
Dim designmod As Worksheet '<-- Design Mods worksheet that we are comparing to the Output Data
Dim DesignMod_DClrow As Integer '<-- Variable used to count to the last low in the DC Number Column of Design Mods Spreadsheet
Dim designmoddc As Range '<-- Variable used to identify the range of values being checked in Design Mods is the DC Numbers Column K from K4 to the end of the column
Dim valuetofind As String '<-- DC Number used as matching criteria between Design Mods spreadsheet and Output Data
'Test Variables for integrating references to from Output worksheet
Dim testset As Worksheet
Dim test2_lrow As Integer
Dim test As Range
Dim valuetofindw2 As String
'Variables below pertain the routine itself
Dim found As Boolean '<-- this condition has to be false to start the routine
'Start of Routine
found = False
'Definition of Data Ranges in Design Mods spreadsheet
Set designmod = ActiveWorkbook.Worksheets("Sheet1")
DesignMod_DClrow = designmod.Range("K4").End(xlDown).Row
Set designmoddc = designmod.Range("K4:K" & DesignMod_DClrow)
'Test variables for integrating values from Output worksheet
Set testset = ActiveWorkbook.Worksheets("Sheet2")
test2_lrow = testset.Range("C2").End(xlDown).Row
Set test = testset.Range("C2:C" & test2_lrow)
'Identify the value being matched against
valuetofind = designmod.Range("L4").Value '<-- the script wont run if I have this value set to a range, and I need to figure out get this to loop so I don't need a variable for every cell im checking against
'test variables to figure out if statement
valuetofindw2 = testset.Range("C2").Value
valuetofindw3 = testset.Range("B2").Value
valuetofindw4 = designmod.Range("K4")
'If Statements performing the comparison
For Each Cell In designmoddc
If Cell.Value = valuetofindw3 Then
found = True
End If
Next
If found = True Then
designmoddc.Cells.Offset(0, 2).Value = testset.Range("B2")
End If
End Sub
You did not answer my clarification questions...
I prepared a solution, able to work very fast (using arrays). Please back-up your workbook, because the code will rewrite the matching cases in column M:M.
Sub MatchValue_TestArrays()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, boolFound As Boolean
Set designMod = Worksheets("Sheet1")
Set testSet = Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:M" & lastRowD).value 'load the range in array
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, 3) = arrTest(t, 1)'fill the array third column (M:M) with values of B:B testSheet...
Exit For
End If
Next t
Next d
designMod.Range("K4:M" & lastRowD).value = arrDes' Drop the modified array
End Sub
Try the updated code, please. It searches now for all occurrences and put each one in a consecutive column:
Sub MatchValue_TestArrays_Extended()
Dim designMod As Worksheet, lastRowD As Long, testSet As Worksheet, lastRowT As Long
Dim arrDes As Variant, arrTest As Variant, d As Long, t As Long, col As Long
Set designMod = Worksheets("Design") ' Worksheets("Sheet1")
Set testSet = Worksheets("TestS") ' Worksheets("Sheet2")
lastRowD = designMod.Range("K" & Cells.Rows.Count).End(xlUp).Row
lastRowT = testSet.Range("C" & Cells.Rows.Count).End(xlUp).Row
arrDes = designMod.Range("K4:AQ" & lastRowD).value
arrTest = testSet.Range("B2:C" & lastRowT).value
For d = 1 To UBound(arrDes, 1)
col = 3 'the column where the occurrence will be put
For t = 1 To UBound(arrTest, 1)
If arrDes(d, 1) = arrTest(t, 2) Then
arrDes(d, col) = arrTest(t, 1): col = col + 1
End If
Next t
Next d
designMod.Range("K4:AQ" & lastRowD).value = arrDes
End Sub
Using Match() is fast when your data is on a worksheet:
Sub MatchValue_Test()
Dim wsDesign As Worksheet, wsOut As Worksheet, m, c As Range
Set wsDesign = ActiveWorkbook.Worksheets("Sheet1")
Set wsOut = ActiveWorkbook.Worksheets("Sheet2")
For Each c In wsDesign.Range(wsDesign.Range("K4"), _
wsDesign.Cells(Rows.Count, "k").End(xlUp)).Cells
m = Application.Match(c.Value, wsOut.Columns("C"), 0)
If Not IsError(m) Then
'if Match() found a hit then m will be the row number on sheet2
c.Offset(0, 2).Value = wsOut.Cells(m, "B").Value
End If
Next c
End Sub

Finding Matching Values Within Arrays in VBA

Pretty basic question here but my VBA skills are pretty rusty. I have two worksheets where a machine just dumps data into them. Each sheet is just one column and SheetA has ~250 rows and SheetB has ~1300 rows. So what I need to do is compare the first value in sheetA to every value in sheetB, if a match is found I need to copy it to another sheet (SheetC) and then move to the next value in SheetA and repeat this till every value in SheetA has been compared to every value in SheetB. I think the best way to do this is with arrays but I cannot for the life of me remember how to do the actual comparison. Below is the code calling up the sheets and arrays I think....any help is appreciated!
Dim SheetA As Variant
Dim SheetB As Variant
Dim RangeToCheckA As String
Dim RangeToCheckB As String
'Get the worksheets from the workbooks
Set wbkA = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\OSM37 with locations 9-30-19.xls")
Set SheetA = wbkA.Worksheets("OSM37")
Set wbkB = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\New folder\Flat Rock and Roush VIN Tracker U625 - U611 Lower control arm welds.xlsx")
Set SheetB = wbkB.Worksheets("Master VIN")
'This is the range in SheetA
RangeToCheckA = "B2:B239"
'This is the range in SheetB
RangeToCheckB = "B4:B1339"
SheetA = SheetA.Range(RangeToCheckA)
SheetB = SheetB.Range(RangeToCheckB)
Without changing much of your code and adding a call to a custom function, you could do the following:
Private Sub CompareWorkBooks()
Dim wbkA As Workbook, wbkB As Workbook
Dim SheetA As Worksheet, SheetB As Worksheet, SheetC As Worksheet
Dim RangeToCheckA As String
Dim RangeToCheckB As String
Dim arrySheetA() As Variant, arrySheetB() As Variant, _
arryOut() As Variant
'Get the worksheets from the workbooks
Set wbkA = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\OSM37 with locations 9-30-19.xls")
Set SheetA = wbkA.Worksheets("OSM37")
Set wbkB = Workbooks.Open(Filename:="H:\Chelsea QE\CD6\Evan West\New folder\Flat Rock and Roush VIN Tracker U625 - U611 Lower control arm welds.xlsx")
Set SheetB = wbkB.Worksheets("Master VIN")
'This is the range in SheetA
RangeToCheckA = "B2:B239"
'This is the range in SheetB
RangeToCheckB = "B4:B1339"
'Value 2 is faster as it doesn't copy formatting
arrySheetA() = SheetA.Range(RangeToCheckA).Value2
arrySheetB() = SheetB.Range(RangeToCheckB).Value2
Set SheetC = wbkB.Worksheets("Sheet C")
arryOut() = FastLookUp(arrySheetA, arrySheetB, 1, 1, 1)
SheetC.Range("A1").Resize(UBound(arryOut, 1), _
UBound(arryOut, 2)).Value = arryOut
End Sub
FastLookUp Function:
Private Function FastLookUp(ByRef arryLookUpVals As Variant, ByRef arryLookUpTable As Variant, _
ByVal lngLookUpValCol As Long, ByVal lngSearchCol As Long, _
ByVal lngReturnCol As Long, _
Optional ByVal boolBinaryCompare As Boolean = True) As Variant
Dim i As Long
Dim dictLooUpTblData As Object
Dim varKey As Variant
Dim arryOut() As Variant
Set dictLooUpTblData = CreateObject("Scripting.Dictionary")
If boolBinaryCompare Then
dictLooUpTblData.CompareMode = vbBinaryCompare
Else
dictLooUpTblData.CompareMode = vbTextCompare
End If
'add lookup table's lookup column to
'dictionary
For i = LBound(arryLookUpTable, 1) To UBound(arryLookUpTable, 1)
varKey = Trim(arryLookUpTable(i, lngSearchCol))
If Not dictLooUpTblData.Exists(varKey) Then
'this is called a silent add with is faster
'than the standard dictionary.Add Key,Item
'method
dictLooUpTblData(varKey) = arryLookUpTable(i, lngReturnCol)
End If
varKey = Empty
Next i
i = 0: varKey = Empty
ReDim arryOut(1 To UBound(arryLookUpVals, 1), 1 To 1)
For i = LBound(arryLookUpVals, 1) To UBound(arryLookUpVals, 1)
varKey = Trim(arryLookUpVals(i, lngLookUpValCol))
'if the lookup value exists in the dictionary
'at this index of the array, then return
'its correspoding item
If dictLooUpTblData.Exists(varKey) Then
arryOut(i, 1) = dictLooUpTblData.Item(varKey)
End If
varKey = Empty
Next i
FastLookUp = arryOut
End Function
FastLookup functions exactly like a VLOOKUP, but is a bit more flexible, because the the lookup column does not have to be the first one in the range you are looking up, as you are allowed to specify which column by providing a value for lngLookUpValCol parameter.
Concerning that you have 3 worksheets in 1 workbook - Worksheets(1) and Worksheets(2) are the one, in which the values in Range("A1:A7") and Range("A1:A3") are compared:
Sub TestMe()
Dim arrA As Variant
Dim arrB As Variant
With Application
arrA = .Transpose(Worksheets(1).Range("A1:A7"))
arrB = .Transpose(Worksheets(2).Range("A1:A3"))
End With
Dim a As Variant
Dim b As Variant
For Each a In arrA
For Each b In arrB
If a = b Then
Worksheets(3).Cells(1 + LastRow(Worksheets(3).Name), 1) = b
End If
Next
Next
End Sub
Function LastRow(wsName As String, Optional columnToCheck As Long = 1) As Long
Dim ws As Worksheet
Set ws = Worksheets(wsName)
LastRow = ws.Cells(ws.Rows.Count, columnToCheck).End(xlUp).Row
End Function
If you are planning to use the code above, it is a good idea to make sure that the values in Worksheets(1) are all unique, otherwise the code would repeat them N times. Or add a dictionary, to exclude repeated values.

Search Similar String using vba in same column

I need to search similar string which exist under same column from a input excel file and group them together and perform some calculation.
Example say : I have input file named : Predictions
FUND_NAME CLASS_NAME FUND_CODE CASHFLOW_IN_FUND_CURRENCY
AA BB SSIS 19200
VV DD SPIS 16200
QQ NN BNIS 15830
CC DJ SSIS -6300
I want a code in VBA which should combine Similar Fund_Codes together and perform some logical calculations on CASHFLOW_IN_FUND_CURRENCY .
Say When 1st nd 4th row has same fund code (SSIS) then I need to ABS(sum(19200-6300))
I know the logic for calculations ,but couldn't find the logic to group the fund_code within same worksheet and same column.
I had tried the Rachels method fuzzy logic in stack overlow but it didn't work ,
I also tried the below code and it did not work .
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("TRANS")
Dim rngFundCode As Range
lRow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
Set rngFundCode = Range("C:C")
For i = 2 To lRow
Cells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 1), rngFundCode, 2, False)
Next i
Could anyone ,let me know how to group the similr string within same column and prform some logic calculation on the other column
Dim ws As Worksheet
Dim lRow As Long, i As Long
Set ws = ThisWorkbook.Sheets("TRANS")
Dim rngFundCode As Range
lRow = Sheet1.Range("C" & Rows.Count).End(xlUp).Row
Set rngFundCode = Range("C:C")
For i = 2 To lRow
Cells(i, 3) = Application.WorksheetFunction.VLookup(Cells(i, 1), rngFundCode, 2, False)
Next i
I want a code in VBA which should combine Similar Fund_Codes together and perform some logical calculations on CASHFLOW_IN_FUND_CURRENCY .
Say When 1st nd 4th row has same fund code (SSIS) then I need to ABS(sum(19200-6300))
I created a class and got the values as a collection from the input file and got this resolved.
Function CalculateReport() As Boolean
Dim bOutput As Boolean: bOutput = False
Dim colPrediction As Collection
Dim objPred As clsPrediction
Dim shtPred As Worksheet
Dim colFunds As New Collection
On Error GoTo ErrorAccessingFile
Set shtPred = g_colInputFiles("txtPredictions").GetSheets(1).GetSheet
On Error GoTo 0
'Get Data from Input Files
Set colPrediction = GetPredictionData(shtPred)
Dim col As Collection
'Split the data by FundCode
For Each objPred In colPrediction
If ItemIsInCollection(colFunds, objPred.Fund_Code) Then
Set col = colFunds(objPred.Fund_Code)
col.Add objPred, objPred.getKey
Else
Set col = New Collection
col.Add objPred, objPred.getKey
colFunds.Add col, objPred.Fund_Code
End If
Next objPred
For Each col In colFunds
If col.Count > 1 Then
'Apply Formula
End If
Next col

Paste Data in excel from one column to another using breaks

I have data in this format as show in the image
I want the data to be in the format as shown in the image below.
That means i want data from 1991 in image 1 to be pasted to 1991 from image 2, similarly, data from 1992 in image 1 to be pasted to 1992 from image 2.
Instead of copying the data from 1991,1992,1993 manually from image 1 and pasting it in image 2, i want it to be done automatically using programming since I have large amount of data that needs to be managed. Can it be done by using VBA?
Please try this code. Comments in the code will help you make the required adjustments, in particular the name of the worksheet which has your data and the first column to transpose.
Option Explicit
Sub Unpivot()
' 18 Feb 2018
Const WsOutName As String = "Output" ' name the result sheet
Const CaptionRow As Long = 1 ' specifies the row with the captions
' the next row is presumed data
Dim WsIn As Worksheet, WsOut As Worksheet
Dim Rng As Range
Dim Arr() As Variant
Dim Cap As Variant
Dim C As Long, Cl As Long ' column, Last column
Dim R As Long, Rl As Long ' row, Last row
Application.ScreenUpdating = False
On Error Resume Next
Set WsOut = Worksheets(WsOutName)
If Err Then
Set WsOut = Worksheets.Add(Before:=Worksheets(1))
WsOut.Name = WsOutName
Else
WsOut.Cells.ClearContents ' delete all existing content
End If
On Error GoTo 0
Set WsIn = Worksheets("Unpivot") ' change to match
With WsIn
Cl = .Cells(CaptionRow, .Columns.Count).End(xlToLeft).Column
' (2 = B) specifies first column to look at
For C = 2 To Cl
' columns can be of different lengths
Rl = .Cells(.Rows.Count, C).End(xlUp).Row
If Rl > CaptionRow Then
Cap = .Cells(CaptionRow, C).Value
Set Rng = Range(.Cells(CaptionRow + 1, C), .Cells(Rl, C))
Arr = Rng.Value
End If
With WsOut
Rl = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(Rl, 1).Resize(UBound(Arr), 1).Value = Cap
.Cells(Rl, 2).Resize(UBound(Arr), 1).Value = Arr
End With
Next C
End With
Application.ScreenUpdating = True
End Sub
Yes, it could be done by VBA. What you need to do is put all your data in Image 1 into a dictionary. then for the image 2, you can just find the key in the dictionary and paste the result the cell.
PS: You can use Offset to access other cell

Resources