VBA Code for Excel VBA Lookup based on multiple inputs(partial) - excel

My Excel Sheet format is similar to this
Name code1 Name Code2 Name Number Input1 Input2
AB XY GSABPEXY1 110 BA BC
BC BA GSBCPEBA1 120
CD CA GSCDPECA1 13
DC DA GSDCPEDA3 140
BC BA GSBCPEBA3 15
Question:
I want to obtain the values in the Name column by matching the inputs as in Input1 AND Input2.
I need these matched values to be pasted in another sheet's predefined specific row and columns cells
Using excel function countifs i am counting the number of rows having same repeating values in the Column A (name code1) and B (name code2) e.g. in above BC and BA which gives a count of 2.
I would like to use this value (mentioned in #3) for the loop iteration
I got this code which looks very close but it lacks two things ABC is predefined in INSTR function and it doesn't have the AND operator - i do not know how to do it. I am very new to VBA so please pardon me if I am missing something simple and/or providing less info.
Code:
Sub Hostname()
Dim K As Long, r As Range, v As Variant
K = 1
Dim w1 As Worksheet, w2 As Worksheet
Set w1 = Sheets("Sheet2")
Set w2 = Sheets("Sheet3")
w1.Activate
For Each r In Intersect(Range("A:A"), ActiveSheet.UsedRange)
v = r.Value
If InStr(v, "ABC") > 0 Then
r.Copy w2.Cells(K, 1)
K = K + 1
End If
Next r
End Sub

OK, I think I see what you want to do. How about this?
Sub Hostname()
Dim codeName1 As String
Dim codeName2 as string
Dim count As Integer
Dim r As Range
Dim targetRange as Range
Set targetSheet = ThisWorkbook.Sheets("MyTargetSheetName").Range("AddressOfFirstCellForDataInput")
codeName1 = "BC"
codeName2 = "BA"
For Each r In ActiveSheet.Range("A:A")
with r
If .Value2 = codeName1 And .Offset(0, 1).Value2 = codeName2 Then
targetRange.Offset(count, 0).value = .Offset(0, 2).Value2
count = count + 1
ElseIf Len(Trim(.Value2)) = 0 Then
Exit For
end if
End With
Next
Call msgbox("Found " & count & "cells matching Name code 1: " & codeName1 & " Name code 2: " & codeName2)
End Sub
This will count the number of cells which match Name Code 1 and Name Code 2. Cand you adapt this to do what you want?

Related

VBA - Copy and Paste Multiple Times Between Excel Sheets

I have a set of x names (in row 4) with corresponding dates (row 3) (the combination of name and date is unique).
I would like to copy the unique name and date, and then paste it x times (where x is the total number of names) in a different sheet.
I would like the code to loop through all names and dates and paste them within column A,B in a new sheet. Where column A has heading name and column B has heading date.
Initial data:
After Code:
What I have attempted so far - i can't seem to get the paste correct
Sub Test()
Dim o As Variant
Dim CountC_Range As Range
Dim cel_3 As Range
Dim MyRange As Range
'count the number of different engagement areas
Worksheets("Sheet8").Activate
Range("B4").Select
Set CountC_Range = Range("B4", Selection.End(xlToRight))
'Set the letter k as number of engagements as we'll use this later
o = WorksheetFunction.CountA(CountC_Range) - "1"
Worksheets("sheet9").Activate
Range("A1").Select
MyRange = Range("Selection.End(xlDown) + 1", "Selection.End(xlDown) + o + 1")
For Each cel_3 In Worksheets("Sheet8").Range("4:4")
If cel_3.Value <> "" Then
MyRange = cel_3.Value
End If
Next cel_3
End Sub
There are plenty of ways to do it, but having this input:
The code below will provide this:
Sub TestMe()
With Worksheets("Source")
Dim k As Long
k = .Range("A4").End(xlToRight).Column
End With
With Worksheets("Target")
Dim i As Long, ii As Long
Dim currentRow As Long
For i = 1 To k
For ii = 1 To k
currentRow = currentRow + 1
.Cells(currentRow, "A") = Worksheets("Source").Cells(3, i)
.Cells(currentRow, "B") = Worksheets("Source").Cells(4, i)
Next
Next
End With
End Sub
Dependencies:
Name the input worksheet "Source"
Name the output worksheet "Target"
A must read - How to avoid using Select in Excel VBA

How to count a pair of texts in one column that are few rows apart using vba?

In workbook A, I'm trying to count when a text, "Dr" occurs then within 5 rows after it, how many cells are blank or the cell is either a text, "Nr" or "Cr".
In another word, I'm trying to count the numbers of pairs of "DR-blank(within 5 rows after DR)", "DR-NF(within 5 rows after DR)", and "DR-CR(within 5 rows after DR)". The data set looks like this:
Column A 0 1 2 3 4 5 6 7 8
Column B Dr Cr Dr Nr
And then I want to copy the result to workbook B.
I've been tried to use offset:
If Range("B2:B901").Value = "D" Then
'V3 = Application.WorksheetFunction.CountBlank(.Range("B2:B901").Offset(5, 0))
Wb.Worksheets("Sheet1").Cells(Rows.Count, "M").End(xlUp).Offset(1, 0).Value = V3
But I always got a "0" in return, meaning the logic wasn't quite right to capture what I intended to do.
Could someone help with the codes? Really appreciated!
This code will iterate through every cell in the range you provide (in this case B1:B901 in sheet1) and if it contains the vale Dr it will then iterate through the subsequent 5 cells to check if they contain the values you are looking for.
It will output the contents of column A and column B to a new workbook, together with your count of nr, cr and blank in columns c, d and e respectively.
Option Compare Text 'this tells VBA that you want you string comparisons to NOT be
'case sesitive. If you want case to be taken into account, then leave
'this line out.
Sub test()
Dim cll As Range
Dim vCellValue As Variant
Dim iterator As Integer
Dim vCountBlank As Integer
Dim vCountCr As Integer
Dim vCountNr As Integer
Dim wb2 As Workbook
Set wb2 = Workbooks.Add
For Each cll In Sheet1.Range("B2:B901")
vCountBlank = 0
vCountCr = 0
vCountNr = 0
If cll.Value = "Dr" Then
For iterator = 1 To 5
vCellValue = cll.Offset(iterator, 0).Value
If vCellValue = "Nr" Then vCountNr = vCountNr + 1
If vCellValue = "Cr" Then vCountCr = vCountCr + 1
If vCellValue = "" Then vCountBlank = vCountBlank + 1
Next iterator
End If
wb2.Sheets(1).Cells(cll.Row, 1).Value = cll.Offset(0, -1).Value
wb2.Sheets(1).Cells(cll.Row, 2).Value = cll.Value
wb2.Sheets(1).Cells(cll.Row, 3).Value = vCountNr
wb2.Sheets(1).Cells(cll.Row, 4).Value = vCountCr
wb2.Sheets(1).Cells(cll.Row, 5).Value = vCountBlank
Next cll
Set wb2 = Nothing
End Sub

VBA Excel Data Validation of

I was looking for some help on creating a sub which does data validation on the values in column C in a worksheet 'Compare' based on possible values listed in a different worksheet 'mapping' in columns C, D, E etc. I wanted to have the possible values use string/pattern characters like # ? * to make the data validation more flexible. There could be anywhere from 1 to 5+ different possible values which varies by key. Validation differences would be spit into an empty column D in worksheet Compare.
An Example with Data is likely most helpful here.
Static sheet 'mapping' . Key is Column A. Possible values in Columns C onwards
A B C D E F G
v1 CDID #### ###? 0
c52 FHAID ER# EP# INVA Z*
c48 PLID *
v24 CUSTID ### ###Q ###P
c22 MATID ???# ??# ?#
q23 LKKID *
Input original sheet 'Compare'. Key is Column B. Column C contains Data to validate
A B C D
c22 MATID RT3FG
v24 CUSTID 456P
v1 CDID 5
q23 LKKID PORTA
Output sheet 'Compare'. Invalid values noted in Column D.
A B C D
c22 MATID RT3FG Error: Invalid value
v24 CUSTID 456P
v1 CDID 5 Error: Invalid Value
q23 LKKID PORTA
Any ideas on how to make this work? Compare worksheet will have all data starting in A1 with no headers. mapping sheet will be quite large with 100+ rows and probably requires a vlookup or similar to find correct row.
Assuming * is anything # is a number and ? is a char I came up with this
Sub CompareToMapping()
Dim mapSheet As Worksheet: Set mapSheet = Sheets("Mapping")
Dim compSheet As Worksheet: Set compSheet = Sheets("Compare")
Dim mcell As Range
Dim ccell As Range
Dim rcell As Range
'Loop throw all the rows in the compare sheet
For Each ccell In compSheet.Range("a1", compSheet.Range("a" & compSheet.Rows.Count).End(xlUp))
'loop through and find a matching row from Mapping sheet
For Each mcell In mapSheet.Range("a1", mapSheet.Range("a" & mapSheet.Rows.Count).End(xlUp))
If mcell = ccell And mcell.Offset(0, 1) = ccell.Offset(0, 1) Then
'loop through valid format strings
For Each rcell In mapSheet.Range(mcell, mapSheet.Cells(mcell.Row, mapSheet.Columns.Count).End(xlToLeft))
ccell.Offset(0, 3) = "Error: Invalid value"
If FormatCorrect(ccell.Offset(0, 2).Text, rcell.Offset(0, 2).Text) Then
'show error in column d
ccell.Offset(0, 3) = ""
Exit For
End If
Next rcell
Exit For
End If
Next mcell
Next ccell
End Sub
Function FormatCorrect(inString As String, inFormat As String) As Boolean
Dim i As Integer: i = 0
Dim curS, curF As String
FormatCorrect = True
' first check for *
If inFormat = "*" Then
FormatCorrect = True
' next check if strings are the same length
ElseIf Len(inString) <> Len(inFormat) Then
FormatCorrect = False
Else
'compare 1 character at a time
For i = 1 To Len(inString)
curS = Mid(inString, i, 1)
curF = Mid(inFormat, i, 1)
If curF = "?" Then ' needs to be a letter
If IsNumeric(curS) Then
FormatCorrect = False
Exit For
End If
ElseIf curF = "#" Then ' needs to be a number
If Not IsNumeric(curS) Then
FormatCorrect = False
Exit For
End If
Else ' needs to be an exact match
If curF <> curS Then
FormatCorrect = False
Exit For
End If
End If
Next i
End If
End Function
Tested and worked for me. Good luck :)

VBA Looping/Logic Issue

I am writing a macro in excel for work and I am having trouble. In this scenario there are two sheets, "BU" and "TOPS Information". When the macro is used it is supposed to search every line of "BU" for the value found in "TOPS Information", then go to the next line of "TOPS Information and repeat the process. If it finds a correct match it is supposed to copy a cell and paste it into "TOPS Information".
Here is the code:
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
This Macro obviously only works if "TOPS Information" is selected at the time. Any and all help would be most appreciated. THANKS!
You sorta answered it yourself. Range refers to the current sheet, but when you're bouncing around then you have to qualify it.
Prefix your ranges with the appropriate sheet like so,
Sub QIM()
Dim j As Integer
Dim k As Integer
Dim i As Integer
Dim l As Integer
Dim m As Integer
Dim searchArray(1 To 3) As String
j = 0
k = 1
'WARNING: Temporary Sheet Names
lastRowTOPS = Worksheets("TOPS Information").Cells(Rows.Count, "A").End(xlUp).Row
lastRowBU = Worksheets("BU").Cells(Rows.Count, "A").End(xlUp).Row
'Cycle through BU rows
For j = lastRowTOPS To 1 Step -1
'Cycle through searchArray for each BU row
For k = lastRowBU To 1 Step -1
'//////////////////////////////////////
x = Sheets("BU").Range("B" & k).Value
y = Sheets("TOPS Information").Range("C" & j).Value
If StrComp(x, y) = 1 Then
Sheets("BU").Range("C" & k).Copy
Sheets("TOPS Information").Range("H" & j).PasteSpecial
End If
'//////////////////////////////////////
Next k
Next j
End Sub
Assuming only want to copy the top most found data in BU to TOPS, you can use below.
Sub QIM()
Dim oWS_TOPS As Worksheet, oWS_BU As Worksheet ' Worksheet objects
Dim oRng_TOPS As Range, oRng_BU As Range ' Range objects
Dim R_TOPS As Long, R_BU As Long
Set oWS_TOPS = ThisWorkbook.Worksheets("TOPS Information") ' <-- Replace this "TOPS Information" to match future changes
Set oWS_BU = ThisWorkbook.Worksheets("BU") ' <-- Replace this "BU" to match future changes
R_TOPS = oWS_TOPS.Cells(Rows.Count, "A").End(xlUp).Row
R_BU = oWS_BU.Cells(Rows.Count, "A").End(xlUp).Row
' Search column B of BU for each cell in column C of TOPS
For Each oRng_TOPS In oWS_TOPS.Columns("C").Cells ' <-- Replace this "C" to match future changes
' Exit if row is more than last A column data
If oRng_TOPS.Row > R_TOPS Then Exit For
For Each oRng_BU In oWS_BU.Columns("B").Cells ' <-- Replace this "B" to match future changes
' Exit if row is more than last A column data
If oRng_BU.Row > R_BU Then Exit For
' Check if Ranges match (## See Update ##)
If InStr(1, oRng_TOPS.Value, oRng_BU.Value, vbTextCompare) > 0 Then
' Copy column C of found row in BU to column H of TOPS, then exit
oWS_BU.Cells(oRng_BU.Row, "C").Copy oWS_TOPS.Cells(oRng_TOPS.Row, "H") ' <-- Replace these "C" and "H" to match future changes
Exit For
End If
Next
Next
Set oWS_TOPS = Nothing
Set oWS_BU = Nothing
End Sub
There are many ways to achieve your goal, and this is one of it.
UPDATE Note on comparing cell values (String):
StrComp(S1,S2[,mode]) only return 3 values {-1, 0, 1} to indicate if S1 is less/equal/greater than S2. If you want an exact match (case sensitive and exact spacing), use If StrComp(S1,S2) = 0 Then.
InStr([i,]S1,S2[,mode]) only returns positive values - it returns the character location of first appearance of S2 in S1. If S2 is not found then it returns zero.
You can also use Trim(sText) to remove leading/ending spaces of sText.
Hope below screenshot says more.

Counting the Frequencies of Words in Excel Strings

Suppose I have a column of arbitrary length where each cell contains a string of text. Is there a way to determine what words appear most frequently in the column (not knowing in advance which words to check) and subsequently order these words along with their frequencies in a two column table? Would VBA be best for this task?
As an example, a cell might contain the string "This is a string, and the # of characters inthis string is>0." (errors intentional)
Select a portion of column A and run this small macro ( the table will be placed in cols. B & C :
Sub Ftable()
Dim BigString As String, I As Long, J As Long, K As Long
BigString = ""
' Add code to sum both "All" and "all"
' Add code to separate "." "!" etc. from the word preceeding them so that word
' is also counted in the total. For example: "all." should not be reported as 1 ' "all." but "all" be added to the total count of "all" words.
' Would you publish this new code?
For Each r In Selection
BigString = BigString & " " & r.Value
Next r
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next
cl.Add a, CStr(a)
Next a
For I = 1 To cl.Count
v = cl(I)
Cells(I, "B").Value = v
J = 0
For Each a In ary
If a = v Then J = J + 1
Next a
Cells(I, "C") = J
Next I
End Sub
Given this:
I'll use a pivot table to get this:
Best part is, if I got more, it's easy to get Top 5, 10, etc. And it'll always result to unique indices. From there, there are all manners of editing and calculation you can do. :)
Using Google Sheets:
index((Transpose(ArrayFormula(QUERY(TRANSPOSE(SPLIT(JOIN(" ",$B$2)," ")&{"";""}),"select Col1, count(Col2) group by Col1 order by count(Col2) desc limit 20 label Col1 'Word', count(Col2) 'Frequency'",0)))),1,$A6+1)&":"&index((Transpose(ArrayFormula(QUERY(TRANSPOSE(SPLIT(JOIN(" ",$B$2)," ")&{"";""}),"select Col1, count(Col2) group by Col1 order by count(Col2) desc limit 20 label Col1 'Word', count(Col2) 'Frequency'",0)))),2,$A6+1)
In the above $B$2 contains the text string
$A6 = 1 will give you the most used word
$A6 = 2 will give you the second most used word
etc.
This is set to do 20 most frequent. If you want more, increase the limit value to whatever you want.
Here's a tiny fix plus an enhancement to the script kindly offered by "Gary's Student". The fix is that while building the collection is apparently not case-sensitive (and this is correct--we probably don't want new items added to the collection that differ only in case from existing items), the IF statement that does the counting IS case-sensitive as written, so it doesn't count correctly. Just change that line to...
If LCase(a) = LCase(v) Then J = J + 1
And here's my enhancement. To use it, you first select one or more columns but NOT their (first) header/label rows. Then run the script, and it gives results for each selected column in a new worksheet--along with that header/label row so you know what you're looking at.
I'm just a dabbler. I just hack stuff when I need to get a job done, so it's not elegant, I'm sure...
Sub FrequencyV2() 'Modified from: https://stackoverflow.com/questions/21858874/counting-the-frequencies-of-words-in-excel-strings
'It determines the frequency of words found in each selected column.
'Puts results in new worksheets.
'Before running, select one or more columns but not the header rows.
Dim rng As Range
Dim row As Range
Dim col As Range
Dim cell As Range
Dim ws As Worksheet
Dim wsNumber As Long 'Used to put a number in the names of the newly created worksheets
wsNumber = 1
Set rng = Selection
For Each col In rng.Columns
Dim BigString As String, I As Long, J As Long, K As Long
BigString = ""
For Each cell In col.Cells
BigString = BigString & " " & cell.Value
Next cell
BigString = Trim(BigString)
ary = Split(BigString, " ")
Dim cl As Collection
Set cl = New Collection
For Each a In ary
On Error Resume Next 'This works because an error occurs if item already exists in the collection.
'Note that it's not case sensitive. Differently capitalized items will be identified as already belonging to collection.
cl.Add a, CStr(a)
Next a
Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
ws.Name = "F" & CStr(wsNumber)
wsNumber = wsNumber + 1
Worksheets(ws.Name).Cells(1, "A").Value = col.Cells(1, 1).Offset(-1, 0).Value 'Copies the table header text for current column to new worksheet.
For I = 1 To cl.Count
v = cl(I)
Worksheets(ws.Name).Cells(I + 1, "A").Value = v 'The +1 needed because header text takes up row 1.
J = 0
For Each a In ary
If LCase(a) = LCase(v) Then J = J + 1
Next a
Worksheets(ws.Name).Cells(I + 1, "B") = J 'The +1 needed because header text takes up row 1.
Next I
Next col
End Sub

Resources