I have a tricky situation with my one record, which appears in one line in some documents like you can see below:
Therefore I can't extract my data properly, as the other values are thrown.
The full macro you can find here:
https://dotnetfiddle.net/m1tYvi
but what I tried to do. I tried to set up the IF condition for the total length of the string, which appears in the concerned cell.
https://www.excelfunctions.net/vba-len-function.html
that's why I tried something like this:
Dim L As Integer
L = Len("Is there room in the chamber to install a new closure :")#
Set rngFound = rngSearch.Find(What:=qu(q), Lookat:=xlPart, LookIn:=xlValues)
With datTarget
lrowG = .Cells(.Rows.Count, "G").End(xlUp).Row + 1
If rngFound Is Nothing Then
.Cells(lrowG, "G") = "Not found" ' blank
Else
If rngFound > L Then
rngFound.Copy
.Cells(1, "G").PasteSpecial xlPasteValuesAndNumberFormats
rngFound.Offset(1).Copy
.Cells(lrowG, "G").PasteSpecial xlPasteValuesAndNumberFormats
Else
rngFound.Copy
.Cells(lrowG, "G").PasteSpecial xlPasteValuesAndNumberFormats
End If
End If
.Cells(lrowG, ColSort) = datSource.Parent.Name
End With
but unfortunately, it seems not to work. The effect is exactly the same.
Is there any solution to this issue? How can I extract the record I exactly need (case 2) instead of a whole string after the colon or even different data as the offset has been applied?
Related
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. :)
I'm having an issue with the VBA Range.Find method. What the code is doing is looking through all of the worksheets in a workbook, find any matches to data in an array, and change the color of the cell with the same value as that data.
The code works perfect on the first sheet. Then, on the next sheet, it gets hung in an infinite loop. After stepping through the code it seems that Find returns an address that is in Range format ("A2:A2") the first time it is running on this page but then reverts back to Cell format ("A2") after that. It doesn't do this on the first page, just the second one.
I could write some code to check the value returned and trim it down, but I want to fix the problem, not put a patch on it.
Here's the code that breaks:
For x = 1 To UBound(wksSheets)
For y = 0 To (UBound(findData) - 1)
With wkb.Worksheets(x)
Set rng = .Range(DataRange).Find(findData(y), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not rng Is Nothing Then
StrtAdd = rng.Address
Do
.Range(rng.Address).Interior.ColorIndex = 3
Set rng = .Range(DataRange).FindNext(rng)
Loop While Not rng Is Nothing And Not rng.Address = StrtAdd
End If
End With
Next y
Next x
The first time through on the second page the rng.Address is "A2:A2" and gets stored in StrtAdd. Then, when the code hits the .FindNext(rng) rng.Address changes to "A2". Because of this, rng.Address is never equal to StrtAdd even though they are talking about the exact same cell. That's the infinite loop.
Any ideas on the best way to fix this?
wksSheets is an array that contains the worksheet names
findData contains the data that is to be found
Thanks in advance!!
Here is the code I ended up using. I still don't know why sometimes I am getting an address of A2:A2 and sometimes A1 but it does patch the issue.
I used InStr to find the : and then Left to knock the extra off.
I also incorporated the suggestions folks left about cleaning up the code.
For x = 1 To UBound(wksSheets)
For y = 0 To UBound(findData) - 1
With wkb.Worksheets(x)
Set rng = .Range(DataRange).Find(findData(y), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not rng Is Nothing Then
z = InStr(rng.Address, ":")
If z > 1 Then
StrtAdd = Left(rng.Address, (z - 1))
Else:
StrtAdd = rng.Address
End If
Do
rng.Interior.ColorIndex = 3
Set rng = .Range(DataRange).FindNext(rng)
Loop While Not rng Is Nothing And Not rng.Address = StrtAdd
End If
End With
Next y
Next x
While it's a patch, it's a working patch.
I didn't use #VBasic2008's suggestion of Application.Union because the code currently functions properly and I've got to get a version out. If I run into speed issues I will go back and make a new version.
Thanks everyone.
I'm facing a small mystery with the Find function : if get the "researched string" via the code and put it in a varaible, it don't work (gives "Nothing") but if I replace the variable by the actual search request (between some "" of course), it works fine...
Some code will surely help :
The goal here is to :
get a part code number in one excel file,
then go to another excel file (containing the prices of all the parts),
searching for this part number
and then getting it's price (simple offset) for later usages
I defined MainWrkBk as the main file, where I want to import the data and SecondWkbk as the one where I want to get the part price from
Do While Lin < LastRow
TPICode = Worksheets("C Parts Prices").Range("A" & Lin).Value 'Gets the TPI Code (never know...)
Do While col <= NbCol + 2
PartNumber = Worksheets("C Parts Prices").Range(Split(Cells(1, col).Address, "$")(1) & Lin).Value 'gets the part number stored in the table
PartNumber = CStr(PartNumber) 'it's useless, but for safety...
SecondWkbk.Activate 'Go on the second workbook that has just been opened
Worksheets(PriceListSheet).Range("A1").Select 'this is probably useless
With Worksheets(PriceListSheet).UsedRange
Set SearchResult = .Find(What:=PartNumber, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns)
End With
If SearchResult Is Nothing Then
MainWkbk.Activate
Else
Worksheets(PriceListSheet).UsedRange.Find(What:=PartNumber, LookAt:=xlWhole).Select
If SearchResult = PartNumber Then
PriceEuro = ActiveCell.Offset(0, 2)
PriceDollars = ActiveCell.Offset(0, 5)
MainWkbk.Activate
Worksheets("C Parts Prices").Range(Split(Cells(1, col).Address, "$")(1) & Lin + 2).Value = PriceEuro
ElseIf SearchResult = "" Then
MainWkbk.Activate
End If
End If
'Worksheets(TheYear).Select
'Worksheets(TheYear).Range(Split(Cells(1, col).Address, "$")(1) & Lin).Value = PartNumber
col = col + 1
Loop
col = PosStartColumnNb
Lin = Lin + 3
Loop
So, on the line :
With Worksheets(PriceListSheet).UsedRange
Set SearchResult = .Find(What:=PartNumber, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns).Address
End With
1) If I keep the variable PartNumber, whatever is inside, it give back a "nothing", meaning it don't find the data...
2) On the other hand, if in the code I replace PartNumber by its actual number, something like "BR58JE3SO" it is found immediately...
3)If I replace the line
PartNumber = Worksheets("C Parts Prices").Range(Split(Cells(1, col).Address, "$")(1) & Lin).Value
by a simple PartNumber = "BR58JE3SO" , it works fine...
I, of course, tried it that way too :
Set SearchResult = Worksheets(PriceListSheet).UsedRange.Find(What:=PartNumber, LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns)
No difference :(
May someone explain me what's happening, please?
Edit : a small image to show that :
Well, apparently, the only solution would be to create a loop passing through all the cells of the second workbook...
Thank's Find function :'(
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
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.