My title might not be clear so I'll try to explain it with an example.
Let's say I have an excel sheet with one column for city names and another column for state names and a third column for country names. I want to loop through the columns and in a 4th column print what was found in the other 3 columns. So let's say column one is "Houston", column two is "Texas", and column three is "USA", how would I print to the fourth column "HTXUSA"? I have almost no experience in VB in Excel so I'm hoping someone will be able to help.
I searched for similar topics but couldn't find anything that was helpful. A couple threads helped a little bit, but I still don't have this figured out.
To get you started, here is a VBA solution. It uses a public Dictionary object. These really come from VBScript but can be used in VBA in a couple of ways, including by CreateObject. The dictionary is initialized just once, the first time the corresponding Abbreviate function is called. This function takes a range, and for each cell in the range sees if there is a corresponding dictionary key. If so -- the corresponding value is concatenated onto the growing string, if not -- the value itself is. I am making keys upper case so as to make everything case-insensitive:
Public Abbreviations As Variant
Public Initialized As Boolean
Sub Initialize()
Dim A As Variant, i As Long, n As Long
'modify the following:
A = Array("Houston", "H", "Dallas", "D", "Cleveland", "C", _
"Toronto", "T", "Texas", "TX", "Ohio", "OH", _
"Ontario", "ON", "Canada", "CAN")
n = UBound(A) - 1
Set Abbreviations = CreateObject("Scripting.Dictionary")
For i = 0 To n Step 2
Abbreviations.Add UCase(A(i)), A(i + 1)
Next i
Initialized = True
End Sub
Function Abbreviate(R As Range) As String
Dim i As Long, s As String
Dim cell As Range
If Not Initialized Then Initialize
For Each cell In R.Cells
If Abbreviations.exists(UCase(cell)) Then
s = s & Abbreviations(UCase(cell))
Else
s = s & UCase(cell)
End If
Next cell
Abbreviate = s
End Function
A screenshot of how it works:
Related
I have a template with a set number of columns (170) and title headers (row 1 cell name's). This is always the same, until users add columns in between (they're instructed not to change headers). The idea is to make it tamperproof as far as the adding of columns is involved.
I'd like to make variables to hold some of the headers (with the capacity to hold all) and check these with the template to find out the column number (in a loop I reckon). It's probably wisest to make a function to call upon it?
Dim ColHeader1Str as string 'literal row 1, column 1 value (which is always
'the same string and position in the template)
Dim iColHeader1 as integer 'holds the (to be set) value of the column number
Set ColHeader1Str = "ColHeader1"
Now I'd like a loop where it loops trough all the columns (last column = 200) and checks to see what the column number is that matches the ColHeader1Str and store this in the iColHeader1
So something like:
Function find_columnNmbr
Dim i As Integer
For i = 1 To 200 Step 1
If 'ColHeader1Str matches actual column header name
'set found integer as iColHeader1 and so forth
Exit For
End If
Next
End Function`
I know I'm missing a few steps and I'm hoping you guys can help me out.
Update: The template has set column headers. When users interact with it a result could be that columns shift position, or they add more. I have a workbook that needs to load data out of the user's altered template.
I.E. The template has columns 1, 2, 3, 4 and the names are column1, column 2 etc. A user ads a random column so now there are 5. The loop needs to loop through the names of the column headers and identify the column number of the original template columns 1, 2 etc based on a string variable with the original names, which I've hard coded beforehand. These are public constants.
What function LookForHeaders do: input a string, then search for the string in usersheet.range(1:1). If it is found, return the column number of that cell, otherwise it returns 0.
Private Function LookForHeaders(ByVal headerName As String) As Long
Dim rng As Range
Dim userSheet As WorkSheet
Set userSheet = 'userSheet here'
On Error GoTo NotFound
LookForHeaders = userSheet.Range("1:1").Find(headerName).Column
Exit Function
NotFound:
LookForHeaders = 0
End Function
Private Sub Test()
Dim rng As Range
Dim template As WorkSheet
Set template = 'template here'
For Each rng In template.Range(Cells(1,1), Cells(1,200))
iColHeader1 = LookForHeaders(rng.Value)
'Do something with iColHeader1
Next rng
End Sub
Not sure what your looking for but here is example
Option Explicit
Public Sub Example()
Dim LastCol As Long
Dim i As Long
LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
For i = 1 To LastCol
If Cells(i) = "Name" Then
Debug.Print Cells(i).Address
End If
Next
End Sub
I have a bunch of Variables I need to declare and was wondering if there's any way to shorten the amount of lines needed to do so. Here's the code:
Sub test()
dim comps as New Collection
dim noOfCompanies as Integer: noOfCompanies = 25
dim c1 as New Names 'Names is a class I have made
dim c2 as New Names
... ' in this gap is c3 to c29
dim c30 as New Names
End Sub
I don't know that you can create a variable and do something like the following, can you? (Note: Psuedocode)
dim i as Integer
for i = 1 to 30
Dim "c" & i as New Names
next i
edit:
#rene mentioned using an array - how would I do so, if later I'm going to set parts of the class properties (sorry, I'm learning classes and don't know the proper terms):
c1.companyCode = 10: c1.companyCountry = "USA": c1.companyName = "Batman LTD"
c2.companyCode = 13: c2.companyCountry = "Krypton": c2.companyName = "Superman LLC"
... 'etc until c30.
Here's what I'm trying so far, but to no avail:
Dim tempC As String, tempN As String
For i = 1 To noOfCompanies
c(i) = "c" & i
tempC = c(i)
Debug.Print tempC 'This will correctly print "c1", "c2", "c3", etc.
Dim c(i) As New Names 'This is where I can't figure out how to declare the different array parts as an individual "new Names" class part.
Debug.Print tempN
Next i
edit2:
Here's why I'm trying to create 30 variables. I get a spreadsheet every week that has a column of codes (the codes being that companyCode I am initializing above). If I find a row with any of the 30 codes I am trying to declare, then I need the companyName and companyCountry to be placed in some other cells on that row. My idea was to be able to just do something like this (psuedocode):
dim rng as Range
rng = Range("A1:A30") 'this has the codes in it, i.e. 13, 10, 11, 20...
for each cel in Rng
'here would be code where I just check for IF the cel.Value is anywhere in companyCode,
'return its equivalent companyCountry and companyName
next cel
So, would a dictionary be best? I could do like
if dict.exists(cel.value)
BUT how could I store the companyCountry and companyName in the same dictionary entry, AFAIK I can only store one key per entry?
...of course, if just saving this info in an excel table somewhere (xlsx or csv) and just opening/using that then closing would be best practice, just let me know!
Dim arrNames(1 to 30) as Names, n
for n=1 to 30
Set arrNames(n)=new Names
next n
arrNames(5).companyCountry = "USA"
EDIT: I think storing your code information on a worksheet and accessing it directly is the "best" approach unless you need high-volume/high-performance lookups (even then it will not be bad...)
For example here's a pretty simple function you can call from VBA:
Function CompanyInfo(companyCode, infoType As String)
Dim rng As Range, colNum As Long, rv
Select Case infoType
Case "Country": colNum = 2
Case "Name": colNum = 3
Case Else
CompanyInfo = "InfoType?"
Exit Function
End Select
rv = Application.VLookup(companyCode, _
ThisWorkbook.Sheets("Codes").Range("A2:C100"), _
colNum, False)
CompanyInfo = IIf(IsError(rv), "???", rv)
End Function
Usage:
Dim v, v2
v = CompanyInfo(10,"Country")
v2 = CompanyInfo(10,"Name")
Example using a collection to create 30 instances of a class containing the name.
If it is imperative that they be able to be retrieved using "c1-c30", then you can either use that as a variable in the class (like Name) or as the collection index/key.
For example:
Names Class:
Private pName As String
Private pOther As Integer
Public Property Get Name() As String
Name = pName
End Property
Public Property Let Name(Value As String)
pName = Value
End Property
Assigning and Printing our 30 Names:
Sub Test()
Dim MyNames As Collection
Set MyNames = New Collection
Dim x
For x = 1 To 30
Dim t As Names
Set t = New Names
t.Name = "c" & x
MyNames.Add t
Next x
Dim y
For Each y In MyNames
MsgBox (y.Name)
Next y
End Sub
In closing, I think your problem is that you want to be able to reference these 30 cnames in your code by name later after having assigned them. That's not going to work and it's a bad coding practice. You shouldn't do:
Dim c1
Set c1 = new Names
c1.Name = "Bob"
Dim c2 '...
There's a reason people don't typically declare 30 variables with incremental numbers. The reason is because there is a better way. That way is typically using a collection of variable types or an array of variable types that you can reference using an index or a loop.
If you're creating 30 instances of a certain data type, and you want to give them each unique values, create a table or even a static array to hold their values and assign them in a loop.
To follow up, if you want to reference them using c & x then add a variable to your class called ID and assign to that.
You might want to look into using a dictionary if you would like to be able to quickly retrieve the ID without looping through and checking ID's.
Edit:
I'm glad you explained your end game. You are absolutely over-complicating this scenario.
A simple VLOOKUP formula and a lookup table would save you from having to code anything in VBA at all.
Example:
Create a named range called LookupTable that contains the company ID's on the far left:
Then, use these formulas to search your table for the ID, and give you the name/location.
Parameter 1 is the value to Lookup
Parameter 2 is our LookupTable
Parameter 3 is the column from our table to return
(1 = ID, 2 = Company Name, 3 = City)
Parameter 4 says we want an exact match only.
=VLOOKUP(A1,LookupTable,2,FALSE)
I'm not sure if I like the use of "Names" as a class name since "Names" already has an Excel VBA meaning, but if that's what you want.
As others have pointed out, an array is probably the way to go. But if you really want to have 30 variables and you don't want to do a lot of typing, you can do something like this:
Sub DeclareVars()
Dim i As Long, v As Variant
ReDim v(1 To 30)
For i = 1 To 30
v(i) = "c" & i & " As New Names"
Next i
Debug.Print "Dim " & Join(v, ", ")
End Sub
Run it once and copy the result from the immediate window into your code. If you know Python you can use a 1-liner in the Python shell and type even less. Just evaluate:
"Dim " + ", ".join('c' + str(i) + " As New Names" for i in range(1,31))
Why don't you store your c1, ... c30 objects properties in a table, an xml file, a csv file, or any other of the multiple types of files? That can store data and be read via VBA.
So, when needed, you can just open the table, and populate an array of your object's properties with the values in the table? If your table/file contains 30 lines, an array of 30 objects will then be created.
By doing this, you will also separate your code from your data, which is usually considered as a best practise.
I have the need to execute some VBA code when a sheet changes. For this I have an If-then-else situation.
In any particular row (I have a variable number of rows (i.e. line items)):
if column "Type" = Range("A") then
column "Amount" needs to be unlocked
set to the value of Range("B") and locked
else if column "Type" = Range("C") then
column "Amount" needs to be unlocked
set to the value of Range("C") and locked
else
the column "Amount" needs to unlocked.
In the worksheet change event, I unlock/lock using ActiveSheet.Protect and .Unprotect with a password from a range.
I am now trying to figure out how to do this. Specifically, how do I use the column names - like in formula's?
=== for Excel 2007+ ===
If you are using Excel 2007+, I recommend using ListObject, ListColumns and ListRows (study the object model).
Philosophy behind my approach:
Forms, Data and Reports should always be separated, so...
Gather all your data into a Table, in a dedicated sheet. Select your data and Ctrl+(T or L). Make sure every sheet has only 1 table of data.
Using Tables, you'll be able to make use of the ListObject, ListColumns and ListRows objects.
Here's the finished code for the entire thing.
Public Sub test()
IntersectColumnRows ActiveSheet, "", "Type", "Amount", Range("A1"), Range("B1"), Range("C1")
End Sub
Public Sub IntersectColumnRows(currentSheet As Worksheet, sheetPassword As String, columnTitle_Type As String, columnTitle_Amount As String, rangeA As Range, rangeB As Range, rangeC As Range)
'variable declaration
Dim listO As ListObject
Set listO = currentSheet.ListObjects(1)
'Takes care of sheet protection
Dim isSheetProtected As Boolean
isSheetProtected = currentSheet.ProtectionMode
If isSheetProtected Then _
currentSheet.Unprotect (sheetPassword)
'store your type column
Dim columnRangeType As Range
Set columnRangeType = listO.ListColumns(columnTitle_Type).Range
'store your 2nd column
Dim columnRangeAmount As Range
Set columnRangeAmount = listO.ListColumns(columnTitle_Amount).Range
'the actual routine you are asking for
Dim listR As ListRow
For Each listR In listO.ListRows
'intersect the TYPE column with the current row
Dim typeRangeIntersection As Range
Set typeRangeIntersection = Application.Intersect(listR.Range, columnRangeType)
'intersect the AMOUNT column with the current row
Dim amountRangeIntersection As Range
Set amountRangeIntersection = Application.Intersect(listR.Range, columnRangeAmount)
'the logic you required
If typeRangeIntersection.Value = rangeA.Value Then
amountRangeIntersection.Locked = False
amountRangeIntersection.Value = rangeB.Value
amountRangeIntersection.Locked = True
ElseIf typeRangeIntersection.Value = rangeC.Value Then
amountRangeIntersection.Locked = False
amountRangeIntersection.Value = rangeC.Value
amountRangeIntersection.Locked = True
Else
amountRangeIntersection.Locked = False
End If
Next
'Cleans up sheet protection
If isSheetProtected Then _
currentSheet.Protect (sheetPassword)
End Sub
Here's the "how-I-did-it":
Store the ListColumn.Range for all required columns (Type, Amount)
For-loop with every ListRow...
I intersect the ListRow.Range with the ListColumn.Range
Apply your desired logic
Beyond the code, study how...
I included the PROTECT/PASSWORD logic in there, so you can remove it if you want to.
Each variable has a very explicit name
I didn't include any hard-coded value so it remains parametric, if you need to adapt some stuff for different sheets
I an trying to extract data from sheet "Record" by matching an entered reference number in sheet "Form" with those numbers in column B of "Record." I was able to come up with the VB code below through command button click. However, it will only return a single value from sheet "Record" column i and coding for each will really be time consuming.
Private Sub CommandButton1_Click()
With Application.WorksheetFunction
Sheets("Form").Range("b:b") = _
.Index(Sheets("Record").Range("h:h"), .Match(Sheets("Form").Range("i13"), Sheets("Record").Range("b:b"), 0), 1)
End With
End Sub
I'm wondering if is it possible to copy values from sheet "Record" columns H-Q to sheet "Form" columns B-K if the reference number in cell I13 of sheet "Form" matches any value on column B of sheet "Record?" Because what i encounter most of the time is returning the entire row.
I would really appreciate any help. Thanks
It might be brute force, but I think the best way is to loop through the data like this:
'Find the last row of data
Public Function Get_Last_Row_Find(ByVal rngToCheck As Range) As Long
Dim rngLast As Range
Set rngLast = rngToCheck.Find(what:="*", searchorder:=xlByRows, SearchDirection:=xlPrevious)
If rngLast Is Nothing Then
Get_Last_Row_Find = rngToCheck.Row
Else
Get_Last_Row_Find = rngLast.Row
End If
If Get_Last_Row_Find <= 1 Then
Get_Last_Row_Find = 2
End If
End Function
Public Sub CommandButton1_Click
x = Get_Last_Row_Find(Sheets("Record").Range("B:B")
for i = 1 to x
if Sheets("Form").Range("I13").Value = Sheets("Record").Range("B:B").Offset(i-1,0).Value then 'match
Worksheets("Record").Range("H"&i&":Q"&i).Copy _
destination:=Worksheets("Form").Range("B"&i&":K"&i)
next i
Note the two methods of "offsetting": you can use the .Offset method or you can use a variable and concatenate it within the Range("") text.
Code not tested.
I have the following Data in Excel.
CHM0123456 SRM0123:01
CHM0123456 SRM0123:02
CHM0123456 SRM0256:12
CHM0123456 SRM0123:03
CHM0123457 SRM0789:01
CHM0123457 SRM0789:02
CHM0123457 SRM0789:03
CHM0123457 SRM0789:04
What I need to do is pull out all the relevent SRM numbers that relate to a single CHM ref. now I have a formular that will do some thing like this
=INDEX($C$2:$C$6, SMALL(IF($B$8=$B$2:$B$6, ROW($B$2:$B$6)-MIN(ROW($B$2:$B$6))+1, ""), ROW(A1)))
however this is a bit untidy and I really want to produce this same using short vb script, do i jsut have to right a loop that will run though and check each row in turn.
For x = 1 to 6555
if Ax = Chm123456
string = string + Bx
else
next
which should give me a final string of
SRM0123:01,SRM123:02,SRM0256:12,SRM0123:03
to use with how i want.
Or is ther a neater way to do this ?
Cheers
Aaron
my current code
For x = 2 To 6555
If Cells(x, 1).Value = "CHM0123456" Then
outstring = outstring + vbCr + Cells(x, 2).Value
End If
Next
MsgBox (outstring)
End Function
I'm not sure what your definition of 'neat' is, but here is a VBA function that I consider very neat and also flexible and it's lightning fast (10k+ entires with no lag). You pass it the CHM you want to look for, then the range to look in. You can pass a third optional paramater to set how each entry is seperated. So in your case you could write (assuming your list is :
=ListUnique(B2, B2:B6555)
You can also use Char(10) as the third parameter to seperat by line breaks, etc.
Function ListUnique(ByVal search_text As String, _
ByVal cell_range As range, _
Optional seperator As String = ", ") As String
Application.ScreenUpdating = False
Dim result As String
Dim i as Long
Dim cell As range
Dim keys As Variant
Dim dict As Object
Set dict = CreateObject("scripting.dictionary")
On Error Resume Next
For Each cell In cell_range
If cell.Value = search_text Then
dict.Add cell.Offset(, 1).Value, 1
End If
Next
keys = dict.keys
For i = 0 To UBound(keys)
result = result & (seperator & keys(i))
Next
If Len(result) <> 0 Then
result = Right$(result, (Len(result) - Len(seperator)))
End If
ListUnique = result
Application.ScreenUpdating = True
End Function
How it works: It simple loops through your range looking for the search_string you give it. If it finds it, it adds it to a dictionary object (which will eliminate all dupes). You dump the results in an array then create a string out of them. Technically you can just pass it "B:B" as the search array if you aren't sure where the end of the column is and this function will still work just fine (1/5th of a second for scanning every cell in column B with 1000 unique hits returned).
Another solution would be to do an advancedfilter for Chm123456 and then you could copy those to another range. If you get them in a string array you can use the built-in excel function Join(saString, ",") (only works with string arrays).
Not actual code for you but it points you in a possible direction that can be helpful.
OK, this might be pretty fast for a ton of data. Grabbing the data for each cell takes a ton of time, it is better to grab it all at once. The the unique to paste and then grab the data using
vData=rUnique
where vData is a variant and rUnique is the is the copied cells. This might actually be faster than grabbing each data point point by point (excel internally can copy and paste extremely fast). Another option would be to grab the unique data without having the copy and past happen, here's how:
dim i as long
dim runique as range, reach as range
dim sData as string
dim vdata as variant
set runique=advancedfilter(...) 'Filter in place
set runique=runique.specialcells(xlCellTypeVisible)
for each reach in runique.areas
vdata=reach
for i=lbound(vdata) to ubound(vdata)
sdata=sdata & vdata(i,1)
next l
next reach
Personally, I would prefer the internal copy paste then you could go through each sheet and then grab the data at the very end (this would be pretty fast, faster than looping through each cell). So going through each sheet.
dim wks as worksheet
for each wks in Activeworkbook.Worksheets
if wks.name <> "CopiedToWorksheet" then
advancedfilter(...) 'Copy to bottom of list, so you'll need code for that
end if
next wks
vdata=activeworkbook.sheets("CopiedToWorksheet").usedrange
sData=vdata(1,1)
for i=lbound(vdata) + 1 to ubound(vdata)
sData=sData & ","
next i
The above code should be blazing fast. I don't think you can use Join on a variant, but you could always attempt it, that would make it even faster. You could also try application.worksheetfunctions.contat (or whatever the contatenate function is) to combine the results and then just grab the final result.
On Error Resume Next
wks.ShowAllData
On Error GoTo 0
wks.UsedRange.Rows.Hidden = False
wks.UsedRange.Columns.Hidden = False
rFilterLocation.ClearContents