The code is supposed to compare string A1 and A2 with string B1 and B2 respectively.
If it doesn't match, insert a line, copy B1 and B2 data to A1 and A2 respectively and paint the entire row red.
Otherwise check if the value inside C1, C2, C3 and C4 is the same as D1, D2, D3 and D4.
If yes, do nothing, otherwise paint the C cell with yellow.
The issue seems to be with the string compare.
It creates rows and paints stuff seemingly randomly.
Option Explicit
Sub CompareValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1EndRow As Long, ws2EndRow As Long, i As Long
Dim dbAMarca As String, dbASubGrupo As String
Dim dbAQtddVendas As Range, dbAValorVendas As Range
Dim dbAQtddEstoque As Range, dbAValorEstoque As Range
Dim dbBMarca As String, dbBSubGrupo As String
Dim dbBQtddVendas As Range, dbBValorVendas As Range
Dim dbBQtddEstoque As Range, dbBValorEstoque As Range
Set ws1 = Application.Workbooks("1.xlsx").Sheets("Sheet1")
Set ws2 = Application.Workbooks("2.xls").Sheets("Sheet2")
i = 4
ws1EndRow = ws1.UsedRange.Rows(ws1.UsedRange.Rows.Count).Row
While i < ws1EndRow
dbASubGrupo = ws1.Cells(i, "D")
dbAMarca = ws1.Cells(i, "E")
Set dbAQtddVendas = ws1.Cells(i, "F")
Set dbAValorVendas = ws1.Cells(i, "G")
Set dbAQtddEstoque = ws1.Cells(i, "M")
Set dbAValorEstoque = ws1.Cells(i, "O")
dbBSubGrupo = ws2.Cells(i - 1, "H")
dbBMarca = ws2.Cells(i - 1, "J")
Set dbBQtddVendas = ws2.Cells(i - 1, "Q")
Set dbBValorVendas = ws2.Cells(i - 1, "R")
Set dbBQtddEstoque = ws2.Cells(i - 1, "AF")
Set dbBValorEstoque = ws2.Cells(i - 1, "AI")
If Not (StrComp(dbAMarca, dbBMarca, 1) And StrComp(dbASubGrupo, dbBSubGrupo, 1)) Then
ws1.Rows(i).EntireRow.Insert
ws1.Rows(i).EntireRow.Interior.Color = vbRed
ws1.Cells(i, "D").Value = ws2.Cells(i - 1, "H").Value
ws1.Cells(i, "E").Value = ws2.Cells(i - 1, "J").Value
ws1EndRow = ws1.UsedRange.Rows(ws1.UsedRange.Rows.Count).Row
Else
If Not dbAQtddVendas.Value = dbBQtddVendas.Value Then
dbAQtddVendas.Interior.Color = vbYellow
End If
If Not dbAValorVendas.Value = dbBValorVendas.Value Then
dbAValorVendas.Interior.Color = vbYellow
End If
If Not dbAQtddEstoque.Value = dbBQtddEstoque.Value Then
dbAQtddEstoque.Interior.Color = vbYellow
End If
If Not dbAValorEstoque.Value = dbBValorEstoque.Value Then
dbAValorEstoque.Interior.Color = vbYellow
End If
End If
i = i + 1
Wend
End Sub
StrComp returns a numeric value not a boolean value, this changes how it works with Not operator. If your goal is to check whether the two are exact match you can replace the string compare statement with the following:
If dbAMarca<>dbBMarca and dbASubGrupo<>dbBSubGrupo Then
Ended up fixing it myself. There were many issues with the original code, and now they're all fixed including the one SaintSnowmad pointed out. Here's the final (working) code in case anyone needs something similar in the future.
Option Explicit
Sub CompareValues()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim ws1EndRow As Long, ws2EndRow As Long
Dim i As Long, j As Long, k As Long
Dim dbAMarca As Range, dbASubGrupo As Range
Dim dbAQtddVendas As Range, dbAValorVendas As Range
Dim dbAQtddEstoque As Range, dbAValorEstoque As Range
Dim dbBMarca As Range, dbBSubGrupo As Range
Dim dbBQtddVendas As Range, dbBValorVendas As Range
Dim dbBQtddEstoque As Range, dbBValorEstoque As Range
Set ws1 = Application.Workbooks("1.xlsx").Sheets("Sheet1")
Set ws2 = Application.Workbooks("2.xls").Sheets("Sheet2")
i = 4
j = 0
k = 0
ws1EndRow = ws1.UsedRange.Rows(ws1.UsedRange.Rows.Count).Row
While i < ws1EndRow
Set dbASubGrupo = ws1.Cells(i, "D")
Set dbAMarca = ws1.Cells(i, "E")
Set dbAQtddVendas = ws1.Cells(i, "F")
Set dbAValorVendas = ws1.Cells(i, "G")
Set dbAQtddEstoque = ws1.Cells(i, "M")
Set dbAValorEstoque = ws1.Cells(i, "O")
Set dbBSubGrupo = ws2.Cells(i - 1 - k, "H")
Set dbBMarca = ws2.Cells(i - 1 - k, "J")
Set dbBQtddVendas = ws2.Cells(i - 1 - k, "Q")
Set dbBValorVendas = ws2.Cells(i - 1 - k, "R")
Set dbBQtddEstoque = ws2.Cells(i - 1 - k, "AF")
Set dbBValorEstoque = ws2.Cells(i - 1 - k, "AI")
If dbAMarca.Value <> dbBMarca.Value Or dbASubGrupo.Value <> dbBSubGrupo.Value Then
For j = i To i + 10
If ws1.Cells(i, "D").Value = ws2.Cells(j - k, "H").Value And ws1.Cells(i, "E").Value = ws2.Cells(j - k, "J") Then
ws1.Rows(i).EntireRow.Insert
ws1.Rows(i).EntireRow.ClearFormats
ws1.Rows(i).EntireRow.Interior.Color = vbRed
ws1.Cells(i, "D").Value = ws2.Cells(j - 1 - k, "H").Value
ws1.Cells(i, "E").Value = ws2.Cells(j - 1 - k, "J").Value
ws1EndRow = ws1.UsedRange.Rows(ws1.UsedRange.Rows.Count).Row
Exit For
End If
If j = i + 10 Then
ws1.Rows(i).EntireRow.Interior.Color = vbCyan
k = k + 1
End If
Next
Else
If Not dbAQtddVendas.Value = dbBQtddVendas.Value Then
dbAQtddVendas.Interior.Color = vbYellow
End If
If Not dbAValorVendas.Value = dbBValorVendas.Value Then
dbAValorVendas.Interior.Color = vbYellow
End If
If Not dbAQtddEstoque.Value = dbBQtddEstoque.Value Then
dbAQtddEstoque.Interior.Color = vbYellow
End If
If Not dbAValorEstoque.Value = dbBValorEstoque.Value Then
dbAValorEstoque.Interior.Color = vbYellow
End If
End If
i = i + 1
Wend
End Sub
Related
The code I have takes cells containing the delimiter (; ) from a column, and creates new rows (everything except the column is duplicated) to separate those values.
What I have
I need this for multiple columns in my data, but I don't want the data to overlap (ex: for 3 columns, I want there to be only one value per row in those 3 columns). It would be ideal if I could select multiple columns instead of only one as my code does now.
What I want
Sub splitByCol()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
Do While r.Row > 1
ar = Split(r.Value, "; ")
If UBound(ar) >= 0 Then r.Value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).Value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
Try this code
Sub Test()
Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
a = Range("A1").CurrentRegion.Value
ReDim b(1 To 1000, 1 To UBound(a, 2))
For i = LBound(a) To UBound(a)
For ii = 2 To 3
x = Split(a(i, ii), "; ")
For Each e In x
k = k + 1
b(k, 1) = k
b(k, 2) = IIf(ii = 2, e, Empty)
b(k, 3) = IIf(ii = 3, e, Empty)
b(k, 4) = a(i, 4)
Next e
Next ii
Next i
Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub
I'd go this way
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
With .Resize(UBound(currFirstColValues) + 1)
.Value = currFirstColValues
.Offset(, 2).Value = thirdColValues(iRow, 1)
End With
End With
With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
With .Resize(UBound(currSecondColValues) + 1)
.Value = currSecondColValues
.Offset(, 1).Value = thirdColValues(iRow, 1)
End With
End With
Next
End With
End Sub
Follow the code step by step by pressing F8 while the cursor is in any code line in the VBA IDE and watch what happens in the Excel user interface
EDIT
adding edited code for a more "parametric" handling by means of a helper function
Sub SplitByCol()
With Worksheets("Sheet")
With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
Dim firstColValues As Variant
firstColValues = .Value
Dim secondColValues As Variant
secondColValues = .Offset(, 1).Value
Dim thirdColValues As Variant
thirdColValues = .Offset(, 2).Value
.Offset(, -1).Resize(, 4).ClearContents
End With
Dim iRow As Long
For iRow = LBound(firstColValues) To UBound(firstColValues)
Dim currFirstColValues As Variant
currFirstColValues = Split(firstColValues(iRow, 1), "; ")
Dim currSecondColValues As Variant
currSecondColValues = Split(secondColValues(iRow, 1), "; ")
WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
currFirstColValues, thirdColValues(iRow, 1), _
-1, 2
WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
currSecondColValues, thirdColValues(iRow, 1), _
1, 1
Next
End With
End Sub
Sub WriteOne(refCel As Range, _
currMainColValues As Variant, thirdColValue As Variant, _
mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)
With refCel.Offset(, mainValuesOffsetFromRefCel)
With .Resize(UBound(currMainColValues) + 1)
.Value = currMainColValues
.Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
End With
End With
End Sub
Please, use the next code. It uses arrays and should be very fast for big ranges to be processed, working mostly in memory:
Sub testSplitInsert()
Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("B1:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
k = 1 'initialize the variable to load the final array
For i = 1 To UBound(arr)
arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
For j = 0 To UBound(arrSp)
arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
arrSp = Split(Replace(arr(i, 1)," ",""), ";")
For j = 0 To UBound(arrSp)
arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
Next j
Next
sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub
It processes the range in columns "B:D" and returns the result in columns "G:I". It can be easily adapted to process any columns range and return even overwriting the existing range, but this should be done only after checking that it return what you need...
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
tmpArr(1, j) may be a date or a string. If it is a date then I need to find it in Range(i4:ck4). The dates in this range are formatted as dates. My code below is not finding my dates. What am I doing wrong?
Data is Code in column A which is alphanumeric and may be 3 characters long. Tbk mnth is column B and is a date.
Code Tbk Mnth
BX 1-Oct-06
C7 1-Dec-11
C7 1-Apr-12
LA 1-Feb-15
NJ 1-Mar-15
Dim rng As Range
Dim tmpArr As Variant
Dim Dict As Object, tmpDict As Object
Dim i As Long, j As Long
Dim v, key
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim item As Variant
Dim d As Date
Set Dict = CreateObject("Scripting.Dictionary")
Set ws = Worksheets("Data")
Set ws2 = Worksheets("Plan")
Set ws3 = Worksheets("test")
With ws
Set rng = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2))
tmpArr = rng.Value
For i = LBound(tmpArr, 1) To UBound(tmpArr, 1)
' Test if value exists in dictionary. If not add and set up the dictionary item
If Not Dict.exists(tmpArr(i, 1)) Then
Set tmpDict = Nothing
Set tmpDict = CreateObject("Scripting.Dictionary")
Dict.Add key:=tmpArr(i, 1), item:=tmpDict
End If
' Set nested dictionary to variable to edit it
Set tmpDict = Nothing
Set tmpDict = Dict(tmpArr(i, 1))
' Test if value exists in nested Dictionary, add if not and initiate counter
If Not tmpDict.exists(tmpArr(i, 2)) Then
tmpDict.Add key:=tmpArr(i, 2), item:=1
Else
' Increment counter if it already exists
tmpDict(tmpArr(i, 2)) = tmpDict(tmpArr(i, 2)) + 1
End If
' Write nested Dictionary back to Main dictionary
Set Dict(tmpArr(i, 1)) = tmpDict
Next i
' Repurpose array for output setting to maximum possible size (helps with speed of code)
ReDim tmpArr(LBound(tmpArr, 2) To UBound(tmpArr, 2), LBound(tmpArr, 1) To UBound(tmpArr, 1))
' Set starting counters for array
i = LBound(tmpArr, 1)
j = LBound(tmpArr, 2)
' Convert dictionary and nested dictionary to flat output
For Each key In Dict
tmpArr(j, i) = key
i = i + 1
For Each v In Dict(key)
tmpArr(j, i) = v
tmpArr(j + 1, i) = Dict(key)(v)
i = i + 1
Next v
Next key
' Reshape array to actual size
ReDim Preserve tmpArr(LBound(tmpArr, 1) To UBound(tmpArr, 1), LBound(tmpArr, 2) To i - 1)
'Change dates less than date in cell 1,9 to overdue and find the row number associated to the code
d = ws.Cells(1, 9).Value
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
dte = tmpArr(1, j)
If dte < d Then
tmpArr(1, j) = "Overdue"
b = b + tmpArr(2, j)
Else
With ws2.Range("e5:e280")
Set c = .find(tmpArr(1, j), LookIn:=xlValues)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
tmpArr(2, j) = firstAddress
End If
End With
End If
Next j
For j = LBound(tmpArr, 2) To UBound(tmpArr, 2)
l = Len(tmpArr(1, j))
Select Case l
Case Is <= 3
k = j
rw = tmpArr(2, k)
Case 7
With ws2.Cells(rw, 8)
.Value = .Value + tmpArr(2, j)
End With
Case 10
'find column for date numbers
With ws2.Range("I4:CK4")
d = tmpArr(1, j)
Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
Debug.Print d
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
'See what tmpArr looks like
With ws3.Cells(2, 5)
Range(.Offset(0, 0), .Cells(UBound(tmpArr, 2), UBound(tmpArr, 1))) = Application.Transpose(tmpArr)
End With
End With
End Sub
You might use : DateValue() if your date d is set as date format in cells then delete CDate() because Cdate() is used to convert String to date
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(CDate(d)), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
So if your cell is as date format maybe use this one :
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(d), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
Edit
Case 10
With ws2.Range("i4:ck4")
Dim d As Date
d = tmpArr(1, j)
Set c = .find(DateValue(Format(CDate(d), "dd/mm/yyyy")), LookIn:=xlValues, LookAt:=xlPart)
If Not c Is Nothing Then
firstAddress = c.Address
firstAddress = Mid(firstAddress, 4, 3)
End If
End With
End Select
Next j
I've got a function which merges cells in table if whole range has the same value (eg. if A1:G1 is equal to A2:B2 it will merge cells like A1&A2, B1&B2 etc. More here: How to check if two ranges value is equal)
Now I would like, to change color on table created by that funcion, like first row (doesn't matter if merged or no) filled with color, second blank etc. but I have no idea whether I should color it with merging function or create another which will detect new table with merged rows as one etc. Below is my code:
Sub test()
Dim i As Long, j As Long, k As Long, row As Long
row = Cells(Rows.Count, 2).End(xlUp).row
k = 1
For i = 1 To row Step 1
If Cells(i, 1).Value = "" Then Exit For
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
k = i + 1
End If
Next i
End Sub
Try:
Option Explicit
Sub test1()
Dim LastColumn As Long, LastRow As Long, i As Long
With ThisWorkbook.Worksheets("Sheet1")
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
LastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 2 To LastRow Step 2
.Range(Cells(i, 1), .Cells(i, LastColumn)).Interior.Color = vbGreen '<- You could change the color
Next i
End With
End Sub
Before:
After:
Edited Solution:
Option Explicit
Sub test1()
Dim rng As Range
With ThisWorkbook.Worksheets("Sheet1")
Set rng = .UsedRange
.ListObjects.Add(xlSrcRange, rng, , xlYes).Name = "Table1"
.ListObjects("Table1").TableStyle = "TableStyleLight3"
End With
End Sub
Result:
So, after some time I've figured it out by myself. Below is the code:
Dim i As Long, j As Long, k As Long, l As Long, c As Integer
row = Cells(Rows.Count, 2).End(xlUp).row
k = 7
c = 1
For i = 7 To row Step 1
If Join(Application.Transpose(Application.Transpose(Range(Cells(i, 1), Cells(i, 3)))), Chr(0)) <> Join(Application.Transpose(Application.Transpose(Range(Cells(i + 1, 1), Cells(i + 1, 3)))), Chr(0)) Then
If i <> k Then
For j = 1 To 3 Step 1
Application.DisplayAlerts = False
Range(Cells(i, j), Cells(k, j)).Merge
Application.DisplayAlerts = True
Next j
End If
Select Case c
Case 0
Range(Cells(k, 1), Cells(k, 3)).Interior.Color = xlNone
c = 1
Case 1
For l = 0 To i - k Step 1
Range(Cells(k + l, 1), Cells(k + l, 3)).Interior.Color = RGB(217, 225, 242)
Next l
c = 0
End Select
k = i + 1
End If
Next i
I have a search function which works perfectly for searching for Exact Numerical values, However I need to adapt it so it searches for text within a cell and only extracts that text. For example it searches column 7. In column 7 there may be a cell containing the words Interface - HPT, SAS, LPT Ideally I would like to search for the word Interface - HPT then extract Only this text from the cell. I also need the search function to be able to do this for multiple different values. So for example run a search for Interface - HPT
Interface - SAS and Interface LPT separate from each other. Is this Possible ?
Here is the code I have at the moment:
Sub InterfaceMacro()
Dim Headers() As String: Headers = _
Split("Target FMECA,Part I.D,Line I.D,Part No.,Part Name,Failure Mode,Assumed System Effect,Assumed Engine Effect", ",")
Worksheets.Add().Name = "Interface"
Dim wsInt As Worksheet: Set wsInt = Sheets("Interface")
wsInt.Move after:=Worksheets(Worksheets.Count)
wsInt.Cells.Clear
Application.ScreenUpdating = False
With wsFHA
For i = 0 To UBound(Headers)
.Cells(2, i + 2) = Headers(i)
.Columns(i + 2).EntireColumn.AutoFit
Next i
.Cells(1, 2) = "Interface TABLE"
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).MergeCells = True
.Range(.Cells(1, 2), .Cells(1, UBound(Headers) + 2)).HorizontalAlignment = xlCenter
.Range(.Cells(1, 2), .Cells(2, UBound(Headers) + 2)).Font.Bold = True
End With
Dim SourceCell As Range, FirstAdr As String
Dim RowCounter As Long: RowCounter = 3
Dim SearchTarget() As String
SearchTarget = Split("9.1,18.0", ",")
For i = 0 To UBound(SearchTarget)
If Worksheets.Count > 1 Then
For j = 1 To Worksheets.Count - 1
With Sheets(j)
Set SourceCell = .Columns(7).Find(SearchTarget(i), LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
FirstAdr = SourceCell.Address
Do
wsInt.Cells(RowCounter, 2).Value = SearchTarget(i)
wsInt.Cells(RowCounter, 3).Value = .Cells(SourceCell.Row, 6).Value
wsInt.Cells(RowCounter, 4).Value = .Cells(3, 10).Value
wsInt.Cells(RowCounter, 5).Value = .Cells(2, 10).Value
wsInt.Cells(RowCounter, 6).Value = .Cells(SourceCell.Row, 2).Value
For k = 0 To SourceCell.Row - 1
If .Cells(SourceCell.Row - k, 3).Value <> "continued." Then
wsFHA.Cells(RowCounter, 7).Value = .Cells(SourceCell.Row - k, 3).Value
Exit For
End If
Next k
wsInt.Cells(RowCounter, 8).Value = .Cells(SourceCell.Row, 14).Value
Set SourceCell = .Columns(7).FindNext(SourceCell)
RowCounter = RowCounter + 1
Loop While Not SourceCell Is Nothing And SourceCell.Address <> FirstAdr
End If
End With
Next j
End If
Next i
End Sub
The part I believe needs editing is this section
Dim SourceCell As Range, FirstAdr As String
Dim RowCounter As Long: RowCounter = 3
Dim SearchTarget() As String
SearchTarget = Split("9.1,18.0", ",")
For i = 0 To UBound(SearchTarget)
If Worksheets.Count > 1 Then
For j = 1 To Worksheets.Count - 1
With Sheets(j)
Set SourceCell = .Columns(7).Find(SearchTarget(i), LookAt:=xlWhole)
If Not SourceCell Is Nothing Then
FirstAdr = SourceCell.Address
You can define the array to search the same way as you define it for numbers.
To search also part of the cell content you need to change .Find(SearchTarget(i), LookAt:=xlWhole) to .Find(SearchTarget(i), LookAt:=xlPart).
VBA looks in formulas / results the same way as it works in Find / Replace dialog. (set .LookIn to either xlValues or xlFormulas)