General purpose of my project is to copy data from a file I get daily into another file with specific formatting and correcting the addresses (so I can create a serial letter).
I have the table with streetnames (in Col I)
that needs to be augmented with the postal code (in Col K) based on a reference table in a separate workbook.
I tried adding this code I found for a somewhat similar question into my (otherwise working):
Dim wsziel As Worksheet
Set wsziel = Workbooks("VBA_Tagesliste.xlsx").Worksheets("Adressen")
Workbooks.Open Filename:="[...]\TEST VBA\street_ref.xls"
Dim wsstreetref As Worksheet
Set wsstreetref = Workbooks("street_ref.xls").Worksheets("Abgleich")
Dim rngPLZ As Range, rngFillPLZ As Range, c As Range, fLoc As Range, comb As Range, fAdr As String
Set rngPLZ = wsstreetref.Range("A2:A1222") 'Reference
Set rngFillPLZ = wsziel.Range(":I3") 'Fill
For Each c In rngPLZ
If c <> "" Then
Set fLoc = rngFillPLZ.Find(c.Value & "*", LookIn:=xlValues, LookAt:=xlPart)
If Not fLoc Is Nothing Then
fAdr = fLoc.Address
Do
Set comb = Union(c.Offset(0, -2), c.Offset(0, -1))
comb.Copy fLoc.Offset(0, -2)
fLoc.Value = c.Value
Set fLoc = rngFillPLZ.FindNext(fLoc)
Loop While fAdr <> fLoc.Address
End If
End If
Next
I do not fully understand what the code in the Do is doing, so I had to do a bit trial and error which didn't work.
Another complication (which I'd like to put on hold until I get a grasp on how to solve this one) is that there are some streets where I need to incorporate the house number (Col J) into the mix, as the reference looks like this
(the empty postcodes is a simplification, because the tend to go 1,2,3,5 in one and 4,6,7,8... in the next post code - My plan was to colour those fields instead and later solve them manually as they shouldn't be too many).
So, BigBens question actually pushed me in the right direction.
I didn't quite understand the SUMFIS function, but in the quest to do so I stumbled upon INDEX and MATCH, which worked perfectly after putting my street references in another worksheet in the document.
[...]
Set rngToFill = wsziel.Range("BA3:BA" & LastRowZiel) 'PLZ-Lookup in Hilfszeile
rngToFill.FormulaLocal = "=INDEX(streetref!B1:B1223; VERGLEICH(I3; streetref!A1:A1222; 0))" 'PLZ-Lookup aus zweiter Tabelle
Set source = wsziel.Range("BA3:BA" & LastRowZiel)
Set target = wsziel.Range("K3")
source.Copy
target.PasteSpecial Paste:=xlPasteValues
[...]
At least for the single-postcode-streets, but I'm optimistic I'll solve the multi-streets today. :)
Related
I am trying to create a Module that will format an excel spreadsheet for my team at work. There is one column that will contain the word "CPT" and various CPT codes with descriptions.
I need to delete all text (CPT description) after the 5 digit CPT code but alsp keep the word CPT in other cells.
For example: Column S, Row 6 contains only the word "CPT" (not in quotations)
Then Column S, Row 7 contains the text "99217 Observation Care Discharge"
This setup repeats several times throughout Column S.
I would like for Row 6 to stay the same as it is ("CPT") but in Row 7 i only want to keep "99217"
Unfortunately, this is not possible to do by hand as there are several people who will need this macro and our spreadsheets can have this wording repeated hundreds of times in this column with different CPT codes and descriptions.
I have tried various If/Then statements, If/Then/Else
Sub CPTcolumn()
Dim celltxt As String
celltxt = ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Dim LR As Long, i As Long
LR = Range("S6" & Rows.Count).End(xlUp).Row
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
Else
With Range("S6" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
Next i
End If
End Sub
When i try to run it I get Various "Compile Errors"
I would do this differently.
Given:
The cell to be modified will be the cell under a cell that contains CPT
in the algorithm below, we look for CPT all caps and only that contents. Easily modified if that is not the case.
Since you write " a five digit code", we need only extract the first five characters.
IF you might have some cells that contain CPT where the cell underneath does not contain a CPT code, then we'd also have to check the contents of the cell beneath to see if it looked like a CPT code.
So we just use the Range.Find method:
Sub CPT()
Dim WS As Worksheet, R As Range, C As Range
Dim sfirstAddress As String
Set WS = Worksheets("sheet4")
With WS.Cells
Set R = .Find(what:="CPT", LookIn:=xlValues, lookat:=xlWhole, _
MatchCase:=True)
If Not R Is Nothing Then
sfirstAddress = R.Address
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
Do
Set R = .FindNext(R)
If Not R.Address = sfirstAddress Then
Set C = R.Offset(1, 0)
C.Value = Left(C.Value, 5)
End If
Loop Until R.Address = sfirstAddress
End If
End With
End Sub
If this sequence is guaranteed to only be in Column S, we can change
With WS.Cells
to With WS.Columns(19).Cells
and that might speed things up a bit.
You may also speed things up by adding turning off ScreenUpdating and Calculation while this runs.
Your first error will occur here:
ActiveSheet.Range("S6" & Rows.Count).End(xlUp).Text
Because you're trying to retrieve text from the last used range starting .End(xlUp) at Range("S61048576"), which is roughly 58 times the row limit in Excel. You might change Range("S6" & Rows.Count) to Range("S" & Rows.Count)
Your second error will occur here:
LR = Range("S6" & Rows.Count).End(xlUp).Row
Which will be the same error.
The third error will occur here:
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
Next i
You cannot nest half of an If-End If block in a For-Next loop, or vice-versa and you've done both. If you want to iterate and perform an If-End If each iteration, you need to contain the If-End If within the For-Next like
For i = 1 To LR
If InStr(1, celltxt, "CPT") Then
'Is the purpose here to do nothing???
Else
With Range("S" & i)
.Value = Left(.Value, InStr(.Value, " "))
End With
End If
Next i
EDIT:
For technical accuracy, your first error would actually be your broken up For-Next and If-End If, as you wouldn't even be able to compile to execute the code to run into the other two errors.
You can simply use the Mid function in the worksheet.
As I understood from your question that you need to separate numbers and put them in other cells, is this true?
To do this, you can write this function in cell R6 like this
=Mid(S6,1,5)
Then press enter and drag the function down and you will find that all the cells containing numbers and texts have been retained numbers in them
I have a excel spreadsheet where I have values in a form format, I need to convert them into tabular format. example -
Project ID/Name: 3001 Miscellaneous Improvements
Location: This is Project Location.
Description: This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description. This is the project description.
Justification: This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification. This is the project Justification.
Duration: Q1 2013 to Ongoing
Status: This is some status
Each block starts with Project ID/Name, however, Description and Justification can vary according to the size of text they have. All the headings are in Column A. If I use Find for ProjectID - and use offset at a fixed length it works but if Justification and description are bigger or smaller they don't fall in correct place. Please help.
You can use TextToColumns. Example:
'Split this cells when find ':" or <TABS>
[A1:A6].TextToColumns Destination:=[A1], DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, Tab:=True, OtherChar:=":", _
FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
From what I understand, you want to convert a vertical "form" into a table of data. I suggest adding that data to an existing table.
Here's the code.
You'll need to edit some variables (sheet/range names)
Public Sub test()
'insert your code to get each Worksheet and it's column range here
transferFormDataToTable Range("Sheet1!B1:B100"), Worksheets(2).ListObjects(1)
End Sub
Public Sub transferFormDataToTable(yourRangeB As Range, dbTable As ListObject)
' make a reference to the form data range
Dim formRange As Range
Set formRange = yourRangeB
'create a new ListRow in your target table
Dim listR As ListRow
Set listR = dbTable.ListRows.Add
'transfer the data from form to the new ListRow
Dim lastHeader As String
lastHeader = ""
Dim targetColumnOffset As Integer
targetColumnOffset = 0
Dim currentColumn As Integer
currentColumn = 0
Dim i As Integer
For i = 1 To formRange.Count
'if the row's header is not empty and different than previous row
'then we'll know we have a new column of different type of data
If lastHeader <> formRange(i).Offset(0, -1).Value And formRange(i).Offset(0, -1).Value <> "" Then
lastHeader = formRange(i).Offset(0, -1).Value
targetColumnOffset = 0
currentColumn = currentColumn + 1
End If
'this loop captures data that might have been placed in columns to the right of the input cell
Dim rowString As String
rowString = ""
Dim j As Integer
j = 0
Do While True
If formRange(i).Offset(0, j).Value <> "" Then
If rowString = "" And targetColumnOffset = 0 Then
rowString = formRange(i).Offset(0, j).Value
Else
rowString = rowString & "; " & formRange(i).Offset(0, j).Value
End If
j = j + 1
Else
Exit Do
End If
Loop
If targetColumnOffset = 0 Then
listR.Range(currentColumn).Value = rowString
Else
listR.Range(currentColumn).Value = listR.Range(currentColumn).Value & rowString
End If
targetColumnOffset = targetColumnOffset + 1
'Exit the loop if it seems to get the end
If formRange(i).Value = "" And formRange(i).Offset(0, -1).Value = "" Then _
Exit For
Next i
End Sub
Notes:
Excel has weird bugs occasionally when creating editing with VBA empty tables that have only 1 or 2 rows. I suggest using this macro only when your table has 3+ rows.
Send me a note if you want a much more complete version of this. Namely, a problem you might eventually have with this short version is that the code will screw up if a user switches columns around.
EDIT
I just adapted the code to your requirements. This is bound to get buggy eventually though. I'd really look into convincing the team about just how much they need to find a more appropriate tool. Good luck.
If I have created a collection, can I search search the collection and RETURN THE INDEX number from within the collection?
Due to my newbie status, I can't post screenshots of what I'm trying to do, so let me try to explain what I'm trying to accomplish:
I have a history log from a warehouse database in Excel format that is several thousand lines long-- each line representing a transaction of product moving in or out of as many as 10 different bins. My goal is to identify all the possible different bins in the thousands of lines, copy/transpose those ~10 bins to column headers, and then go through each transaction and copy the transaction quantity (+1,-3, etc) to the correct column, thus being able separate the transactions and more easily identify and generate an accounting of when product moved in/out of each respective bin. This would sort of look like a PivotTable, but that isn't really how it would work.
Here is the code I am working on so far, with comments. My problem is explained in the last comment:
Sub ForensicInventory()
Dim BINLOCAT As Collection
Dim Rng As Range
Dim Cell As Range
Dim sh As Worksheet
Dim vNum As Variant
Dim BINcol As Integer
Dim ACTcol As Integer
Dim QTYcol As Integer
Dim i As Integer
Dim lastrow As Long
Dim x As Long
'This part is used to find the relevant columns that will be used later
BINcol = ActiveSheet.Cells(1, 1).EntireRow.Find(What:="BINLABEL", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
ACTcol = ActiveSheet.Cells(1, 1).EntireRow.Find(What:="ACTION", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
QTYcol = ActiveSheet.Cells(1, 1).EntireRow.Find(What:="QUANTITY", LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False).Column
lastrow = Cells(Rows.Count, 1).End(xlUp).Row
i = 0
Set sh = ActiveWorkbook.ActiveSheet
Set Rng = sh.Range(sh.Cells(2, BINcol), sh.Cells(Rows.Count, BINcol).End(xlUp))
Set BINLOCAT = New Collection
'This next section searches the bin column and builds the collection of unique bins that I am interested in.
On Error Resume Next
For Each Cell In Rng.Cells
If Len(Cell.Value) <> 8 And Not IsEmpty(Cell) Then
BINLOCAT.Add Cell.Value, CStr(Cell.Value)
End If
Next Cell
On Error GoTo 0
'Now I take those unique bin names and I put them into a column header on the same spreadsheet, starting in column 10, and spacing every 2 cells thereafter.
For Each vNum In BINLOCAT
Cells(1, 10 + i).Value = vNum
i = i + 2
Next vNum
'Here is where the problem exists for me. This code works and succeeds in copying the QTY
'to column 10, but what I really want to do is determine the index number of the bin from BINLOCAT,
'and use that index number to place the value under the appropriate column header.
For x = 2 To lastrow
Select Case Cells(x, ACTcol).Value
Case "MOVE-IN"
Cells(x, 10).Value = Cells(x, QTYcol).Value
Case "MOVE-OUT"
Cells(x, 10).Value = -Cells(x, QTYcol).Value
Case Else
End Select
Next x
End Sub
In the "For x = 2 to lastrow" loop, I need to find a way to get the INDEX number (1, 2, 3, etc.) from searching for the bin in collection BINLOCAT. BINLOCAT, once created, is static. I envision something like:
neededcolumn = BINLOCAT.item(cells(x,BINcol).value).index (pseudocode)
Then I would replace the 10s in the Case Stmt with "neededcolumn" and this would work.
Maybe I am taking the wrong approach, but it seems to me like I need the collection to be able to do the search portion efficiently. Any thoughts or links to a solution? Based on what I've read, elsewhere, I think that this ability as I'm describing it is not available, but I'm not sure I've understood everything I've read about collections thus far.
Instead of using a for each loop, use a for n = 1 to BINLOCAT.Count loop - then n is your index. Or did I misunderstand?
Disclaimer: Okay, I am going to answer my own question, but I was led to this answer based on #Rory's comment at 13:07 on 8/18. So, thank you, Rory! Rory's answer proper did not enlighten me in the way I needed (or I'm too dumb to see it -- always possible), so I'm not accepting his answer but I want to acknowledge his help. I still suspect there might be a better way than what I am doing, so please feel free to comment/answer/correct me.
In the interest of simplicity and thoroughness, assume the following starting data:
Range("A1:A16")=
BM182B
BM182B
BM182B
BM182B
BM182B
AS662B
BM182B
BM182B
BM182B
BM182B
AS702B
AS642B
BM182B
BM182B
BM182B
BM182B
Based on Rory's comment, this is the first piece of code I came up with:
Sub TestofCollection()
Dim BinCollection1 As Collection
Dim n As Integer
Dim x As Integer
Set BinCollection1 = New Collection
n = 1
On Error Resume Next
For Each Cell In Range("A1:A16")
BinCollection1.Add n, CStr(Cell.Value)
n = n + 1
Next Cell
On Error GoTo 0
For x = 1 To BinCollection1.Count
Range("B" & x).Value = BinCollection1.Item(x)
Next x
End Sub
The problem with this is that output, or the "index" I get, is actually the positional location of each bin during its first occurrence in the list. So the result in the output segment is "1,6,11,12" rather than the desired "1,2,3,4" for the list "BM182B, AS662B, AS702B, AS642B". Whether there is a better way, I do not know, but my solution was to create a "collection of a collection" as follows in the next code:
Sub TestofCollection2()
Dim BinCollection1 As Collection
Dim BinCollection2 As Collection
Set BinCollection1 = New Collection
Set BinCollection2 = New Collection
n = 1
On Error Resume Next
For Each Cell In Range("A1:A16")
BinCollection1.Add Cell.Value, CStr(Cell.Value)
Next Cell
For Each x In BinCollection1
BinCollection2.Add n, BinCollection1.Item(x)
n = n + 1
Next x
On Error GoTo 0
For x = 1 To BinCollection2.Count
Range("C" & x).Value = BinCollection2.Item(x)
Next x
'Test output result should be 3 below
MsgBox "Test Output: " & BinCollection2.Item("as702b")
End Sub
So now, based on this double-collection effort, I can search my multi-thousand line columns of bins and determine their index to create my offset. The index shows up as "1,2,3,4" using those keys in the list.
This is my first question and first answer on Stack Overflow. I will probably give this a couple days to see if anyone has a better answer, but then I will "accept" my own answer here since this is what helped me (can I "unaccept" my answer if a better one shows up later?). Again, comments or suggestions greatly appreciated and accepted. Thank you for viewing.
I have a problem. I spent hours designing a form which works just great with all your feedback. Today, everything went wrong. The reason for this is simple. A few new columns got added and, obviously, the data my form is reading in is now wrong.
Thus I was thinking of trying the following...
Rather than using the column number as below
TK = Cells(ActiveCell.Row, "S").Value 'everything in the form refers to the active row
I could possibly use the column headings in Row 1.
Is that possible ? This way the spreadsheet can have columns added up to as many as a user would like and the form would dynamically scan for the right heading and get the column number that way.
My thought is, on opening the form, read in all the headings, pick out the ones I need and assign them to a variable. Then I use my normal code and substitute the variable into the column section.
It sounds easy, but I have no idea how to do this.
Use the versatile Find to give you a quick method of detecting where your header is - or if it is missing
Find details here
In the code below I have specified that the search must return
an exact match (xlWhole)
a case sensitive match (False)
The match can be a partial match (xlPart) if you were looking to match say Game out of Game X
code
Const strFind = "Game"
Sub GetEm()
Dim rng1 As Range
Set rng1 = ActiveSheet.Rows(1).Find(strFind, , xlValues, xlWhole, , , False)
If Not rng1 Is Nothing Then
MsgBox "Your column is " & rng1.Column
Else
MsgBox strFind & " not found", vbCritical
End If
End Sub
Why use a loop? There's no need to.
Dim col as variant
Col = application.match("my header", rows(1), 0)
If iserror(col) then
'not found
Else
TK = cells(activecell.row, col)
End if
For this purpose I usually use a function which runs through the headers (in the first row of a sheet) and returns the number of the column which contains the value I have searched for.
Public Function FindColumn(HeaderName As String, Sht As String) As Long
Dim ColFound As Boolean
Dim StartingPoint As Range
ColFound = False
Set StartingPoint = Sheets(Sht).Range("A1")
Do While StartingPoint.Value <> ""
If UCase(Trim(StartingPoint.Value)) = UCase(Trim(HeaderName)) Then
FindColumn = StartingPoint.Column
ColFound = True
Exit Do
Else
Set StartingPoint = StartingPoint.Offset(0, 1)
End If
Loop
If Not ColFound Then FindColumn = 0
End Function
Example:
If the first row of your sheet named "Timeline" contains headers like e.g. "Date" (A1), "Time" (B1), "Value" (C1) then calling FindColumn("Time", "Timeline") returns 2, since "Time" is the second column in sheet "Timeline"
Hope this may help you a little.
Your thought is a good one. Reading in column headers to calculate addresses is one way to avoid hard coding - e.g.
Sub Test()
Dim R As Range
Set R = ActiveSheet.[A1]
Debug.Print ColNo(R, "Col1Hdr")
End Sub
Function ColNo(HdrRange As Range, ColName As String) As Integer
' 1st column with empty header is returned if string not found
ColNo = 1
Do While HdrRange(1, ColNo) <> ""
If HdrRange(1, ColNo) = ColName Then Exit Do
ColNo = ColNo + 1
Loop
End Function
Another way I frequently use - and I must admit I prefer it over the above, is to define Enum's for all my tables in a seperate "definition" module, e.g.
Public Enum T_VPN ' sheet VPN
NofHRows = 3 ' number of header rows
NofCols = 35 ' number of columns
MaxData = 203 ' last row validated
GroupNo = 1
CtyCode = 2
Country = 3
MRegion = 4
PRegion = 5
City = 6
SiteType = 7
' ....
End Enum
and use it like
Sub Test1()
Debug.Print ActiveSheet(T_VPN.NofHRows, T_VPN.Country)
End Sub
As you can see, the usage is simpler. Allthough this is again "some kind" of hardcoding, having all definition in one place reduces maintenance significantly.
I'm trying to make a chart, with multiple columns as source area.
Basically, I want to select specific columns, where I skip some columns, and merge them all into one range. I've setup a loop, where I create a range, and append it's address to a string, and seperates them with a comma. I'm pretty sure this is how Excel wants it formatted.
BUT, I cannot seem to create a new range from this string.
I hope someone here can help me out.
I would very much like to avoid, having to copy the columns to a new sheet, and just mark it all as a range.
I have the following code, for making the combined range:
'Loops for each number of sections
For Z = 1 To Sheet1.txtNoSections
'Get gauge to use
Section = Workbooks(ThisWorkbook.Name).Worksheets(1).Cells(26 + Z, 6).Value
'Sets varibel for distance from root
Dist = Workbooks(ThisWorkbook.Name).Worksheets(1).Cells(26 + Z, 3).Value
'Get range to use
Set ChartRange = ActiveSheet.Range(ActiveCell, ActiveCell.Offset(rc, Section))
RangeString = RangeString & ChartRange.AddressLocal
If Z <> 1 Then
RangeString = RangeString & ","
End If
Next Z
I have then tried to get a new range with something like this, but no luck.
Dim ActualRange As Range
Set ActualRange = ActiveSheet.Range(RangeString)
When printing the RangeString, it looks like this:
$S$2$V$6181$S$2:$X$6181,$S$2:$Z$6181,$S$2:$AB$6181,$S$2:$AD$6181,$S$2:$AF$6181,$S$2:$AH$6181,$S$2:$AJ$6181,$S$2:$AL$6181,$S$2:$AN$6181,$S$2:$AP$6181,$S$2:$AR$6181,$S$2:$AT$6181,$S$2:$AV$6181,$S$2:$AX$6181,$S$2:$AZ$6181,$S$2:$BB$6181,$S$2:$BD$6181,$S$2:$BF$6181,$S$2:$BH$6181,$S$2:$BJ$6181,$S$2:$BL$6181,$S$2:$BN$6181,$S$2:$BP$6181
Seems like the same union would do.
As discussed in the comments above, the best way to handle this is to use native VBA functions such as Union.
You can find several references on how to use this:
on Daily dose of Excel
on vba Express
even a "better" Union on Chip Pearson's website
Yet, please note that you can answer you own question (it is even highly recommended) and accept it. This way, you can share your knowledge with the community and the way you've solved your issue with your own code.
IMHO, this would be even better than accepting my answer.
Following JMax's guidance, I ended up using Union.
This is the code I ended up with.
The first time through the loop, I set the CombinedRange to my actual range, and the subsequent runs, I union.
For Z = 1 To Sheet1.txtNoSections
'Get gauge to use
Section = Workbooks(ThisWorkbook.Name).Worksheets(1).Cells(26 + Z, 6).Value
'Get range to use
Set ChartRange = ActiveSheet.Range(ActiveCell, ActiveCell.Offset(rc, 0))
Debug.Print "ChartRange(" & Z & "): " & ChartRange.Address
If Z = 1 Then
Set CombinedRange = ChartRange
Else
Set CombinedRange = Union(CombinedRange, ChartRange)
End If
ActiveCell.Offset(0, 5).Activate
Next Z
Debug.Print "Combined: " & CombinedRange.Address