InStr in Array not populating value if found - excel

I've written the below code to search for a value(Supplier Name) in sheet "Fusion" Column H in sheet "CX" column D. I'm also doing a check the other way around so if the same value(Supplier Name) in sheet CX is in sheet "Fusion". I'm not looking for an Exact match hence the use of Instr and doing the comparison both ways as i'm not sure how a user has entered the information in either sheet.
The data type in either cell should be text.
If a match is found then in the last column of sheet "CX" it should just populate either "Supplier Found" or "Supplier Not Found"
Currently it's not populating the last column with any data but the Macro isn't erroring at any point.
I've tried adding msgboxes and "Here" and "Here3" are being triggered but it doesn't seem to be hitting the section of code that is "Here2" so I think it's there that's causing the issue but not sure how to resolve it.
Screenshot of my Data is :CX Sheet
Fusion Sheet
Any help would be greatly appreciated.
Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim strTemp as string
Dim strCheck as string
Dim i As Long, J As Long
Dim CXArr As Variant
Dim FusionArr As Variant
Dim match As Boolean
Dim CXRng As Range
Dim FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
Set CXRng = CX.Range("A2", CX.Cells(Rows.Count, "A").End(xlUp).Offset(0, 6))
Set FusionRng = Fusion.Range("A2", Fusion.Cells(Rows.Count, "A").End(xlUp).Offset(0, 9))
CXArr = CXRng.Value2
FusionArr = FusionRng.Value2
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
For i = 1 To UBound(CXArr)
Match = False
For J = 1 To UBound(FusionArr)
MsgBox "Here"
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
MsgBox"Here2"
CXArr(i, 6) = "Supplier Found"
Else
Msgbox"Here3"
CXArr(i, 6) = "Supplier not found"
End If
Next J
Next i
End Sub
The expected output i'd expect is: If in Column H of Fusion the Supplier Name is "Supplier A" and the value in Column D of sheet "CX" is "Supplier A LTD" then i'd expect it to populate column G in sheet CX with "Supplier Found" due to it being found in the string.
If you need any more info please let me know.
I don't know how to correctly insert examples of my data else I would have

Option Explicit
Sub CompareCXFusion()
Dim CX As Worksheet
Dim Fusion As Worksheet
Dim i As Long, J As Long, lastRowCX As Long, lastRowFU As Long
Dim CXText As String, FusionText As String
Dim match As Boolean
Dim CXRng As Range, FusionRng As Range
Set CX = ActiveWorkbook.Sheets("CX")
Set Fusion = ActiveWorkbook.Sheets("Fusion")
lastRowCX = CX.Range("D1").SpecialCells(xlCellTypeLastCell).Row - 1
lastRowFU = Fusion.Range("H1").SpecialCells(xlCellTypeLastCell).Row - 1
Set CXRng = CX.Range("D1:D" & lastRowCX)
Set FusionRng = Fusion.Range("H1:H" & lastRowFU)
For i = 1 To lastRowCX
match = False
For J = 1 To lastRowFU
'Debug.Print "Here"
FusionText = FusionRng.Range("A1").Offset(J, 0).Value
CXText = CXRng.Range("A1").Offset(i, 0).Value
If FusionText <> "" And CXText <> "" Then
If InStr(FusionText, CXText) Or InStr(CXText, FusionText) Then
'Debug.Print "Here2"
match = True
End If
End If
Next J
'Result goes to column G of CX range:
If match Then
CXRng.Range("A1").Offset(i, 3).Value = "Supplier found" ' "Supplier found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
Else
CXRng.Range("A1").Offset(i, 3).Value = "Supplier NOT found" '"Supplier NOT found - " & i & " - " & CXRng.Range("A1").Offset(i, 0).Address & " - " & CXRng.Range("A1").Offset(i, 3).Address
End If
Next i
End Sub

You need to make sure to check for case sensitivity:
Dim strTemp as string
Dim strCheck as string
'Inside for I loop
'Inside for j Loop
strTemp = lcase(trim(FusionArr(J, 7)))
strCheck = lcase(trim(CXArr(i, 3)))
If (Instr(strTemp, strCheck) > 0) OR (InStr(strCheck, strTemp) > 0) Then
'...
End If
'end for j
'end for i

Related

populate worksheet from excel table

I have been asked to remake the excel workbook to index where we keep the items.
I have an excel sheet with a table ( excel table) that contains the information.
If the there the value in column 6 ="10" then that means the item is in box 10.
then I need to get the right shelve, this is found by the numbers in column 7 (shelve) and 8 (rack). subsequently the information about the item has to be put in another sheet which gives a visual representation of the box.
I am struggling to get the desired result, does anyone have some suggestions?
Sub box()
Dim rng As Range
For x = 1 To 12
Set rng = Sheets("Register").ListObject("Table1").Range(x, 8).Value
If Range("Table1").ListObject.Range(x, 6).Value = "10" Then
If Range("Table1").ListObject.Range(x, 7).Value = "1" Then
Sheets("box 10").Range(3, rng).Value = Range("Table1").ListObject.Range(x, 2).Value & Range("Table1").ListObject.Range(x, 3)
End If
End If
Next x
End Sub
Please, try the next code. It will iterate in the table DataBodyRange and build a sheet name obtained by concatenation of "Box " with value in table column 6 (in your workbook). If such a sheet does not exist, a warning message is sent and stops the code:
Option Explicit
Sub box()
Dim boxVal As String, tbl As ListObject, shBox As Worksheet, rngRef As Range, x As Long
Dim shelvNo As Long, rackNo As Long
Dim iRow As Long: iRow = 1 ' row where "rack" exist
Dim iCol As Long: iCol = 1 'column letter where "rack" exists (C:C)
Set tbl = Sheets("Register").ListObjects("Table1")
For x = 1 To tbl.DataBodyRange.Rows.Count 'on the frist row there are ABC, ABC etc.
If tbl.DataBodyRange.Cells(x, 1) = "" Then Exit For
boxVal = tbl.DataBodyRange.Cells(x, 6).Value
On Error Resume Next
Set shBox = Sheets("Box " & boxVal) 'set the sheet of the appropriate box 'set the sheet of the appropriate box
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
MsgBox "No sheet named """ & "box " & tbl.DataBodyRange.Cells(x, 6).Value & """ exists" & vbCrLf & _
"Please, create it and run the code again!": Exit Sub
End If
On Error GoTo 0
Set rngRef = shBox.Cells(iRow, iCol)
shelvNo = iRow + 1 + tbl.DataBodyRange.Cells(x, 7).Value
rackNo = iCol + tbl.DataBodyRange.Cells(x, 8).Value - 1
rngRef.Offset(shelvNo, rackNo).Value = tbl.DataBodyRange.Cells(x, 2).Value & " " & tbl.DataBodyRange.Cells(x, 3).Value
Next x
MsgBox "Ready..."
End Sub

How do you Format and Concatenate an Invoice or Bank Statement with Different Ranges in VBA

I have an invoice from a service provider that I need to format so I can use the data in Excel. But, the formatting is not consistent.
There are three (3) columns:
ID
Description
Amount
Many ID#s on the invoice have a one line (row) description.
But just as many have 2-11 lines (rows) of description.
The ID# is only listed once with each set of description lines.
Up to this point, I have used Excel Formulas. But, all my formulas is making things go very slow.
VBA would be way faster.
What I have done is created an index system looking for new ID#s.
Then I have created a cascading concatenate formula based on the given index system.
The amount has been easy to pull out using a LEFT formula, since the amount lists USD.
I then have a second sheet that does a VLOOKUP off of the first sheet to pull the ID's, final concatenated descriptions, and Amounts.
Our last invoice had 17,427 lines of data with only 1,717 ID#s.
Here is an example of what I am working with:
I want it to look like this:
one of the possible solutions below:
'assume that Id in column `A`, Description in column `B`, Amount in `C` and header in row 1
Sub somecode()
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim sh As Worksheet: Set sh = wb.ActiveSheet
Dim lastRow&: lastRow = sh.Cells(Rows.Count, "B").End(xlUp).Row
Dim idColumn As Range: Set idColumn = sh.Range("A1:A" & lastRow)
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim cl As Range, keyID, valueDescription$, valueAmount$
For Each cl In idColumn
If cl.Value <> "" And Not dic.exists(cl.Value) Then
dic.Add cl.Value, sh.Cells(cl.Row, "B").Value & "|" & sh.Cells(cl.Row, "C").Value
keyID = cl.Value
valueDescription = sh.Cells(cl.Row, "B").Value
valueAmount = sh.Cells(cl.Row, "C").Value
ElseIf cl.Value = "" Then
valueDescription = valueDescription & " " & sh.Cells(cl.Row, "B").Value
dic(keyID) = valueDescription & "|" & valueAmount
End If
Next cl
Set sh = wb.Sheets.Add: sh.Name = "Result " & Date & " " & Replace(Time(), ":", "-")
Dim dkey, xRow&: xRow = 1
For Each dkey In dic
sh.Cells(xRow, "A").Value = dkey
sh.Cells(xRow, "B").Value = Split(dic(dkey), "|")(0)
sh.Cells(xRow, "C").Value = Split(dic(dkey), "|")(1)
xRow = xRow + 1
Next dkey
sh.Columns("A:C").AutoFit
End Sub
test:
I wrote code for you to do this job. Please install it in a standard code module. That is one that you have to insert. None of the existing is suitable.
Option Explicit
Enum Nws ' Worksheet setup (set values as required)
NwsFirstDataRow = 2
NwsNumColumns = 8 ' total number of columns in the sheet
NwsID = 1 ' Columns: 1 = column A
NwsDesc ' undefined = previous + 1
NwsAmt = 5 ' 5 = column E
End Enum
Sub MergeRows()
' Variatus #STO 24 Jan 2020
Dim Wb As Workbook
Dim Ws As Worksheet
Dim Rng As Range
Dim RowArr As Variant
Dim Desc As String, Amt As Double
Dim Tmp As Variant
Dim R As Long
' define workbook and worksheet as required
Set Wb = ActiveWorkbook ' this need not be ThisWorkbook
Set Ws = Wb.Worksheets("Invoice") ' change as appropriate
Application.ScreenUpdating = False
With Ws
R = .Cells(.Rows.Count, NwsDesc).End(xlUp).Row
For R = R To NwsFirstDataRow Step -1
If (R Mod 25) = 3 Then 'NwsFirstDataRow Then
Application.StatusBar = "Another " & R & " rows to process."
End If
Tmp = Trim(.Cells(R, NwsID).Value)
If Len(Tmp) Then
Set Rng = Range(.Cells(R, 1), .Cells(R, NwsNumColumns))
RowArr = Rng.Value
RowArr(1, NwsAmt) = TextToAmount(RowArr(1, NwsAmt))
If Len(Desc) Then
' if you want a comma instead of a line break
' replace Chr(10) with "," in the next line:-
RowArr(1, NwsDesc) = RowArr(1, NwsDesc) & Chr(10) & Desc
RowArr(1, NwsAmt) = RowArr(1, NwsAmt) + Amt
Desc = ""
Amt = 0
End If
With Rng
.Value = RowArr
.Cells.VerticalAlignment = xlTop
.Cells(NwsAmt).NumberFormat = "$#,##0.00"
End With
.Rows(R).AutoFit
Else
Tmp = Trim(.Cells(R, NwsDesc).Value)
If Len(Desc) Then Desc = Chr(10) & Desc
Desc = Tmp & Desc
Tmp = TextToAmount(.Cells(R, NwsAmt).Value)
If Tmp Then Amt = Amt + Tmp
.Rows(R).EntireRow.Delete
End If
Next R
End With
With Application
.ScreenUpdating = True
.StatusBar = "Done"
End With
End Sub
Private Function TextToAmount(ByVal Amt As Variant) As Double
Dim Tmp As Variant
Tmp = Trim(Amt)
If Len(Tmp) Then Tmp = Mid(Tmp, InStr(Tmp, "$") + 1)
TextToAmount = Val(Tmp)
End Function
Before you can run it you need to set the enumerations at the top to tell the code where your data and columns are. Toward the same end, please set the variables for workbook (Wb) and worksheet (Ws) in the procedure itself.
Note that the code adds the price, if any, in the rows that are deleted to the amount set against the remaining item.
Finally, you will see that I programmed the different rows to become lines in a single cell. That isn't what you asked for. If you want the items separate by commas look for the remark in the code where you can change this.

Universal VBA Word Count for Excel

I was trying to create a universal, error resistant VBA code that would count words in selected ranges as MS Word does. This below is the best I could do and I was hoping that somebody would have a look and let me know if I missed something or suggest any improvements. The code is quite fast and works with single cell, non-adjacent cells and whole columns, I need it to be as universal as possible. I'll be looking forward to feedback.
Option Explicit
Sub word_count()
Dim r() As Variant 'array
Dim c As Long 'total counter
Dim i As Long
Dim l As Long 'string lenght
Dim c_ch As Long 'character counter
Dim c_s As String 'string variable
Dim cell As range
Dim rng As range
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
ElseIf InStr(1, Selection.Address, ":", vbTextCompare) = 0 And InStr(1, Selection.Address, ",", vbTextCompare) = 0 Then 'for when only one cell is selected
word_count_f Selection.Value, c
MsgBox "Your selected cell '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
Exit Sub
ElseIf InStr(1, Selection.Address, ",", vbTextCompare) > 0 Then 'when user selects more than one cell by clicking one by one -> address looks like ('A1,A2,A3') etc
Application.ScreenUpdating = False
Dim help() As Variant
ReDim help(1 To Selection.Cells.Count)
i = 1
For Each cell In Selection 'loading straigh to array wouldn't work, so I create a helper array
help(i) = cell.Value
i = i + 1
Next cell
r = help
Else 'load selection to array to improve speed
Application.ScreenUpdating = False
r = Selection.Value
End If
Dim item As Variant
For Each item In r
word_count_f item, c
Next item
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") & "' in '" & Selection.Parent.Name & "' has " & c & " words."
End Sub
Private Function word_count_f(ByVal item As Variant, ByRef c As Long)
Dim l As Long 'lenght variable
Dim c_s As String 'whole string variable
Dim c_ch As Long 'characted count variable
l = Len(item)
If l = 0 Then Exit Function
c_s = item
c_s = Trim(c_s)
Do While InStr(1, c_s, " ", vbTextCompare) > 0 'remove double spaces to improve accuracy
c_s = Replace(c_s, " ", " ")
Loop
If InStr(1, c_s, " ", vbTextCompare) = 0 And l > 0 Then 'if there was just one word in the cell
c = c + 1
ElseIf InStr(1, c_s, " ", vbTextCompare) > 0 Then 'else loop through string to count words
For c_ch = 1 To l 'loop through charactes of the string
If (Mid(c_s, c_ch, 1)) = " " Then
c = c + 1 'for each word
End If
Next c_ch
c = c + 1 'add one for the first word in cell
Else 'hopefully useless msgbox, but I wanted to be sure to inform the user correctly
MsgBox "Sorry, there was an error while processing one of the cells, the result might not be accurate", vbCritical
End If
End Function
You can achieve this in a similar way but with less code if you are interested to see?:
Sub word_count()
start_time = Timer
Dim r As Variant 'temp split array
Dim arr As Variant 'array
Dim c As Long 'total counter
If Selection Is Nothing Then
MsgBox "Sorry, you need to select a cell/range first", vbCritical
Exit Sub
Else
c = 0
For Each partial_selection In Split(Selection.Address, ",")
If Range(partial_selection).Cells.Count > 1 Then
arr = Range(partial_selection).Value
Else
Set arr = Range(partial_selection)
'single cell selected don't convert to array
End If
For Each temp_cell In arr
If Len(Trim(temp_cell)) > 0 Then
r = Split(temp_cell, " ")
For Each temp_word In r
If Len(Trim(temp_word)) > 0 Then
c = c + 1
'If the word is just a blank space don't count
End If
Next
'c = c + (UBound(r) - LBound(r) + 1)
'trimmed = Trim(temp_cell)
'c = c + 1 + (Len(trimmed) - Len(Replace(trimmed, " ", "")))
Else 'Blank cell
'Do nothing
End If
Next
Next
End If
Dim item As Variant
time_taken = Round(Timer - start_time, 3)
MsgBox "Your selected range '" & Replace(Selection.Address, "$", "") _
& "' in '" & Selection.Parent.Name & "' has " & c & " words." _
& vbNewLine & "Time Taken: " & time_taken & " secs"
Debug.Print c & " in "; time_taken; " secs"
End Sub
You could try this sort of approach? There may be the need to check for the next character to the space being another space, which would need some additions made. To detect word one as being the same as word one in the count. Also, transferring the range to an array would make it a touch faster.
Function Word_Count(rng As Excel.Range) As Long
Dim c As Excel.Range
Dim s As String
Dim l As Long
For Each c In rng.Cells
s = Trim(c.Value)
If s <> "" Then
If InStr(1, s, " ") > 0 Then
' Find number of spaces. You can use the ubound of split maybe here instead
l = l + (Len(s) - Len(Replace(s, " ", "")))
Else
End If
' Will always be 1 word
l = l + 1
End If
Next c
Word_Count = l
Set c = Nothing
End Function

VBA Excel: How to put a value into a cell using two variable as its location

I am trying to take variant 'row' and 'column' and use them to input an "x" into the cell. 'row' and 'column' have numbers stored in them.
Private Sub CheckInButton_Click()
Dim found_name As Range
Dim name_to_find As String
Dim row As Variant
Dim column As Variant
Dim ColLetter As Variant
Dim xLocation As Excel.Range
row = 0
column = 0
name_to_find = Worksheets("Forms").Range("N5").Value
Set found_name = Worksheets("Updated 1.0").Range("A:A").Find(what:=name_to_find,LookIn:=xlValues, lookat:=xlWhole)
If Not found_name Is Nothing Then
MsgBox (name_to_find & " found in row: " & found_name.row)
row = found_name.row
MsgBox (row)
Else
MsgBox (name_to_find & " not found")
End If
event_to_find = Worksheets("Forms").Range("N3").Value
Set found_event = Worksheets("Updated 1.0").Range("A1:DZ1").Find(what:=event_to_find, LookIn:=xlValues, lookat:=xlWhole)
MsgBox (found_event)
If Not found_event Is Nothing Then
ColLetter = Split(found_event.Address, "$")(1)
MsgBox (event_to_find & " found in column: " & ColLetter)
column = found_event.column
MsgBox (column)
Else
MsgBox (event_to_find & " not found")
End If
Worksheets("Updated 1.0").Cells(column & row).Value2 = "x"
End Sub
You can just use Cells().
Cells(row, column).Value = "X"
So, in your case:
Worksheets("Updated 1.0").Cells(row, column).Value = "x"
.Cells takes two arguments, the row and the column. The & operator concatenates two values, so you're just giving .Cells one argument, the row appended to the column.
Just change Worksheets("Updated 1.0").Cells(column & row).Value2 = "x" to Worksheets("Updated 1.0").Cells(row, column).Value2 = "x"

Searching multiple tables on the same sheet with the column in varying locations and copying them to a different sheet

Hopefully the title is clear. I am trying to search through multiple tables on a single sheet. The information I am looking for is the same for all of the tables, just that the corresponding column is located in different spots (e.g. in one table the column I want to search is in I, while for another table it could be in O.) which makes it a bit more challenging for me.
I want to search through each column that has the same title (Load Number) and depending on its value, copy that entire row over to a sheet that corresponds with that value.
Below is what I have so far in VBA as well as a picture to hopefully clarify my issue.
Any help/advice is appreciated!
http://imgur.com/a/e9DyH
Sub Load_Number_Finder()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
j = 1
Set ws = Sheets.Add(After:=Sheets("Master"))
ws.Name = ("Test Load " & j)
i = 1
Sheets("Master").Select
For Each cell In Sheets("Master").Range("M:M")
If cell.Value = "1" Then
j = 1
'Set WS = Sheets.Add(After:=Sheets("Master"))
'WS.Name = ("Test Load " & j)
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Test Load " & j).Select
ActiveSheet.Rows(i).Select
ActiveSheet.Paste
Sheets("Master").Select
i = i + 1
ElseIf cell.Value = "" Then
' 2, 3, 4, 5, cases
Else
' Something needs to go here to catch when it doesnt have a load number on it yet
End If
' Err_Execute:
' MsgBox "An error occurred."
Next
End Sub
Try this function. This should work for you. Let me know what the results are with your sheet. I made a mock up sheet and tested it, it worked. I can make changes if this is not exactly what you are looking for.
Option Explicit
Sub copyPaste()
Dim rowCount, row_ix, temp, i As Integer
Dim TD_COL_IX As Integer
Dim td_value As String
Dim td_values() As String
rowCount = Worksheets("Master").Cells(Rows.Count, "A").End(xlUp).Row
For row_ix = 1 To rowCount
temp = isNewTable(CInt(row_ix))
If temp > 0 Then
TD_COL_IX = temp
ElseIf TD_COL_IX > 0 Then
td_value = Worksheets("Master").Cells(row_ix, TD_COL_IX)
If Not td_value = "" Then
td_values = Split(td_value, " ")
For i = 0 To UBound(td_values)
If Not sheetExists("Test Load " & td_values(i)) Then
Sheets.Add.Name = "Test Load " & td_values(i)
End If
If Worksheets("Test Load " & td_values(i)).Cells(1, 1).Value = "" Then
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(1, 1)
Else
Dim rowCount_pasteSheet As Integer
rowCount_pasteSheet = Worksheets("Test Load " & td_values(i)).Cells(Rows.Count, "A").End(xlUp).Row
Worksheets("Master").Range(Worksheets("Master").Cells(row_ix, 1), Worksheets("Master").Cells(row_ix, TD_COL_IX - 1)).Copy _
Destination:=Worksheets("Test Load " & td_values(i)).Cells(rowCount_pasteSheet + 1, 1)
End If
Next i
End If
End If
Next row_ix
End Sub
Function isNewTable(row_ix As Integer) As Integer
Dim colCount, col_ix As Integer
colCount = Worksheets("Master").Cells(row_ix, Columns.Count).End(xlToLeft).Column
For col_ix = 1 To colCount
If Not IsError(Worksheets("Master").Cells(row_ix, col_ix).Value) Then
If Worksheets("Master").Cells(row_ix, col_ix).Value = "LD #" Then
isNewTable = col_ix
Exit Function
End If
End If
Next col_ix
isNewTable = 0
End Function
' ####################################################
' sheetExists(sheetToFind As String) As Boolean
'
' Returns true if the sheet exists, False otherwise
' ####################################################
Public Function sheetExists(sheetToFind As String) As Boolean
Dim sheet As Worksheet
sheetExists = False
For Each sheet In Worksheets
If sheetToFind = sheet.Name Then
sheetExists = True
Exit Function
End If
Next sheet
End Function

Resources