I've got a list in Excel which shows the titles in column A and values in column B, like this:
ARTICLE_POSNO 1
ARTICLE_ARTNO 111123
ARTICLE_DESCRIPTION black pens
ARTICLE_POSNO 2
ARTICLE_ARTNO 280708
ARTICLE_DESCRIPTION yellow paper
ARTICLE_POSNO 3
ARTICLE_ARTNO 999912
ARTICLE_DESCRIPTION blue scissors
What I'm trying to do is to build a VB function that creates an array that holds the values, so I can then print it something like this:
POS ART NO DESCRIPTION
1 111123 black pens
2 280708 yellow paper
3 999912 blue scissors
Below is my current script which searches for the titles -> gets the values next to them and finally send a Msgbox of the value. For this list, that would mean 9 Msgboxes.
Ideally, it would show just one messagebox with all article information on it.
Any ideas?
Many thanks in advance!
Sub FindArticles()
Dim FirstAddress As String
Dim MySearch As Variant
Dim Rng As Range
Dim I As Long
MySearch = Array("ARTICLE_POSNO", "ARTICLE_ARTNO", "ARTICLE_DESCRIPTION")
With Sheets("Sheet1").Range("A1:A1000")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
ArtValue = Rng.Offset(0, 1) 'Gather the value to the right
MsgBox ArtValue
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
I assume your input worksheet is named Input and it has the attributes in sequence as in your example, being first column the names and second the values.
1. Create a new worksheet in your workbook and fill the first row with the names (POS, ART NO...).
2. Put this formula in A2.
=INDEX(Input!$B$1:$B$9,(ROW()-1)*3-3+COLUMN(),1)
Copy this cell and paste in the final array.
Not much to explain: it takes 1st, 2nd and 3rd of every 3 values in the values column using row position. Modify the length of input array from 9 to your needs. If your the sequence of the input is not constant it can also be accomplished but it's a little longer.
Related
Using Excel, I'm trying to accomplish the following:
Sample of before & after
I need to convert all the 1's into the corresponding country name of each column. With a small dataset like the sample above, it is easy to do it manually, but not so easy when I have 196 columns x 2 datasets. Any suggestions would be much appreciated!
Duplicate the sheet and clear all the values except the header in the second sheet. Put the following formula in every corresponding cell except the header row in the second sheet.
=IF(INDIRECT(ADDRESS(ROW(),COLUMN(),1,1,"Sheet1"),TRUE)=1,
MID(INDIRECT(ADDRESS(1,COLUMN())),
FIND("[",INDIRECT(ADDRESS(1,COLUMN())))+1,
FIND("]",INDIRECT(ADDRESS(1,COLUMN())))-
FIND("[",INDIRECT(ADDRESS(1,COLUMN())))-1),"")
You can then copy the corresponding cells of the second sheet. Past values into the first sheet. You're done.
{You'll want to remove carriage returns from the formula. Also, you might want to delete the second sheet to hide the magic. :-) }
If you're willing to use vba instead of a formula, I think that this will work for you. It looks for non-empty cells within "A:F" and for those cells it grabs the name inside of [...]
Sub AdjustName()
Dim cell As Range
For Each cell In Range("A2:F" & LastRowInRange_Find(Range("A:F")))
If Len(cell.Value2) > 0 Then
With Cells(1, cell.Column)
cell.Value2 = Mid(.Value2, InStr(.Value2, "[") + 1, Len(.Value2) - 1 - InStr(.Value2, "["))
End With
End If
Next cell
End Sub
Function LastRowInRange_Find(ByVal rng As Range) As Long
'searches range from bottom up looking for "*" (anything)
Dim rngFind As Range
Set rngFind = rng.Find( _
What:="*", _
After:=Cells(rng.row, rng.Column), _
LookAt:=xlWhole, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If Not rngFind Is Nothing Then
LastRowInRange_Find = rngFind.row
Else
LastRowInRange_Find = rng.row
End If
End Function
This question already has answers here:
Matching similar but not exact text strings in Excel VBA projects
(5 answers)
Closed 5 years ago.
In the above pic i have to search the sap code from sheet 2 to the respective..
By Taking some words like Master/13 or visa/chennai we have match the sapcode from sheet 2..
srchString = "visa/20160927/Chennai/FT"
Set rng = Worksheets("Rulebook_Temp").Cells.find(what:=srchString, After:=ActiveCell, LookIn:=xlFormulas, lookat:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Its returning empty for me...
All you really need is to remove the date part of the card type in your source and destination and then you could do a simple lookup. If you have a string like a/b/c/d in cell A1, this will return a/c/d
=IF(LEN(A1)-LEN(SUBSTITUTE(A1,"/",""))>2,REPLACE(A1,FIND("/",A1),FIND("/",A1,FIND("/",A1)+1)-FIND("/",A1),""),A1)
It also checks to make sure that there are more than 2 /, so in the case of a/b the value will be left unchanged. This therefore also works with your premium/007 value
you can try this too
use excel arrays
use this to return the rows that contain the code
IF(ISNUMBER(FIND("Master/13",Sheet2!$A$2:$A$50,1)),ROW(Sheet2!$B$2:$B$50))
then use SMALL to return the first row on the sheet 2 where the match was found
SMALL(IF(ISNUMBER(FIND("Master/13",Sheet2!$A$2:$A$50,1)),ROW(Sheet2!$B$2:$B$50)),1)
Then use index to return the value
INDEX(Sheet2!$B$2:$B$50,SMALL(IF(ISNUMBER(FIND("Master/13",Sheet2!$A$2:$A$50,1)),ROW(Sheet2!$B$2:$B$50)),1))
Enter as an array Control + Shift + Enter
This should work I have tested
You can do that by iterating through the cells as follows
Private Sub CommandButton1_Click()
Dim rng As Range
Set rng = ThisWorkbook.Sheets(1).Range("A1:A60")
Dim foundString, delimiterStr As String
Dim object() As String
delimiterStr = "||"
Dim n As Integer
For n = 1 To rng.Rows.Count
If CStr(rng.Cells(n, 1).Text) Like "*visa/20160927/Chennai/FT*" Then
foundString = foundString & CStr(rng.Cells(n, 1).Text) & delimiterStr
End If
Next n
object = Split(foundString, delimiterStr)
Dim rng_1 As Range
Set rng_1 = ThisWorkbook.Sheets(1).Range("B1")
Dim i As Integer
For i = LBound(object) To UBound(object)
rng_1.Offset(i + 1, 0).Value = object(i)
Next
End Sub
First, my code (below) works, but I am trying to see if it can be simplified. The macro in which this code is located will have a lot of specific search items and I want to make it as efficient as possible.
It is searching for records with a specific category (in this case "Chemistry") then copying those records into another workbook. I feel like using Activate in the search, and using Select when moving to the next cell are taking too much time and resources, but I don't know how to code it to where it doesn't have to do that.
Here are the specifics:
Search column T for "Chemistry"
Once it finds "Chemistry", set that row as the "top" record. e.g. A65
Move to the next row down, and if that cell contains "Chemistry", move to the next row (the cells that contain "Chemistry" will all be together"
Keep going until it doesn't find "Chemistry", then move up one row
Set that row for the "bottom" record. e.g. AX128
Combine the top and bottom rows to get the range to select. e.g. A65:AX128
Copy that range and paste it into another workbook
Here is the code:
'find "Chemistry"
Range("T1").Select
Cells.Find(What:="Chemistry", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
'set top row for selection
toprow = ActiveCell.Row
topcellselect = "A" & toprow
'find all rows for Chemistry
Do While ActiveCell = "Chemistry"
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-1, 0).Select
'set bottom row for selection
bottomrow = ActiveCell.Row
bottomcellselect = "AX" & bottomrow
'define selection range from top and bottom rows
selectionrange = topcellselect & ":" & bottomcellselect
'copy selection range
Range(selectionrange).Copy
'paste into appropriate sheet
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Thanks in advance for any help!
You never need to select or activate unless that's really what you want to do (at the end of the code, if you want the user to see a certain range selected). To remove them, just take out the activations and selections, and put the things on the same line. Example:
wb1.Activate
Sheets("Chemistry").Select
Range("A2").PasteSpecial
Becomes
wb1.Sheets("Chemistry").Range("A2").PasteSpecial
For the whole code; I just loop thorugh the column and see where it starts and stops being "chemistry". I put it in a Sub so you only have to call the sub, saying which word you're looking for and where to Paste it.
Sub tester
Call Paster("Chemistry", "A2")
End sub
Sub Paster(searchWord as string, rngPaste as string)
Dim i as integer
Dim startRange as integer , endRange as integer
Dim rng as Range
With wb1.Sheets("Chemistry")
For i = 1 to .Cells(Rows.Count,20).End(XlUp).Row
If .Range("T" & i ) = searchWord then 'Here it notes the row where we first find the search word
startRange = i
Do until .Range("T" & i ) <> searchWord
i = i + 1 'Here it notes the first time it stops being that search word
Loop
endRange = i - 1 'Backtracking by 1 because it does it once too many times
Exit for
End if
Next
'Your range goes from startRange to endRange now
set rng = .Range("T" & startRange & ":T" & endRange)
rng.Copy
.Range(rngPaste).PasteSpecial 'Paste it to the address you gave as a String
End with
End sub
As you can see I put the long worksheet reference in a With to shorten it. If you have any questions or if it doesn't work, write it in comments (I haven't tested)
The most efficient way is to create a Temporary Custom Sort Order and apply it to your table.
Sub MoveSearchWordToTop(KeyWord As String)
Dim DestinationWorkSheet As Workbook
Dim SortKey As Range, rList As Range
Set SortKey = Range("T1")
Set rList = SortKey.CurrentRegion
Application.AddCustomList Array(KeyWord)
rList.Sort Key1:=SortKey, Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=Application.CustomListCount + 1, MatchCase:=False, _
Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
Application.DeleteCustomList Application.CustomListCount
Set DestinationWorkSheet = Workbooks("Some Other Workbook.xlsx").Worksheets("Sheet1")
rList.Copy DestinationWorkSheet.Range("A1")
End Sub
I am trying to write a VBA script to automate moving things around in an spreadsheet that has a balance sheet imported from an accounting software.
The values on imported balance sheet start at row 5, column A has some text describing what the values of each row mean, and columns B and D have the amounts for each item.
The subtotals for each section and subsection of the balance sheet are on columns C and E. Each subtotal has is in a cell formatted with a solid upper border.
I would like to bring all these subtotals to the same columns as the values (i.e, columns B and D). I've tried to do this using the .Find method to search for cells with the specific format (cells with an upper border) and a Do loop to keep searching until I find all cells that should have a subtotal in it.
Notes:
I didn't use FindNext because it seems that it ignores format settings used in the preceding Find method, as described here.
I tried to used the FindAll function described by Tushar Mehta to go around this problem with FindNext, but it didn't find all cells with the specified format.
Here's the code. Any help is greatly appreciated!
Sub FixBalanceSheet()
Dim LookFor As Range
Dim FoundHere As String 'Address of the cell that should contain a subtotal
Dim beginAt As Range, endAt As Range, rng As Range 'Set the ranges for the sum to get the subtotal
Dim place As String 'String with the address of a cell that will contain a subtotal
Dim WhereToLook As Range 'Range where subtotals are to be found
'Set workbook and worksheet
With Sheets("Sheet1")
Set WhereToLook = Range("A5:F100")
'Every cell containing a subtotal has an upper border. So, look for cells containing border!
With Application.FindFormat.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
'Call search using .Find
Set LookFor = WhereToLook.Find(What:="", After:=Cells(5, 2), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True)
If Not LookFor Is Nothing Then 'Test if a cell with a bottom border is found
'What happens when a subtotal cell is found:
FoundHere = LookFor.Address
Debug.Print "Found at: " & Found
'Loop to set a range, sum values and put them in the right cell
Do
'% find out a range to calculate subtotals and put the value in the right cells %'
'Call for next search
With Application.FindFormat.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = xlAutomatic
.TintAndShade = 0
End With
Set LookFor = WhereToLook.Find(What:="", After:=endAt, SearchFormat:=True)
Debug.Print "LookFor now is: " & LookFor.Address
Rem If LookFor.Address = Found Then ' Do not allow wrapped search
Rem Exit Do
Rem End If
Loop Until LookFor Is Nothing Or LookFor.Address = FoundHere ' Do not allow wrapped search
End If
End With
End Sub
Consider using a range object to loop through your range. You can add a total if you need a grand total, but this is probably an easier way than trying to select all cells that have formatting.
For example:
Sub TestStackOverflowCode()
Dim r As Range
Dim rngToChk As Range
'This is where you'd insert WhereToLook
Set rngToChk = ActiveSheet.Range("B1:B4")
For Each r In rngToChk
'If the top edge does not NOT have a border
If r.Borders(xlEdgeTop).LineStyle <> xlNone Then
'Copy the cell value to two cells to the right
r.Offset(, 2).Value = r.Value
End If
Next r
End Sub
I would recommend going back to the Range.Find/Range.FindNext method. There were some holes in your logic conditions and I believe I've adjusted them.
Set LookFor = WhereToLook.Find(What:="", After:=Cells(5, 2), _
LookIn:=xlFormulas, LookAt:=xlPart, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=True)
If Not LookFor Is Nothing Then 'Test if a cell with a bottom border is found
'What happens when a subtotal cell is found:
FoundHere = LookFor.Address
Debug.Print "Found at: " & FoundHere
'Loop to set a range, sum values and put them in the right cell
Do
'do something with LookFor as a Range Object here
'Call for next search
Set LookFor = WhereToLook.FindNext(After:=LookFor) '<~~ look for next after current cell
Debug.Print "LookFor now is: " & LookFor.Address
Loop Until LookFor.Address = FoundHere ' Do not allow wrapped search (LookFor will never be nothing here)
End If
The findNext may not have worked if
you had [FindFormat.Borders...] after the [Set LookFor = WhereToLook.Find(...]
I do think ThreeTrickPony's answer is more elegant, but in general I'd suggest finding an alternative way to identify cells rather than formatting.
I am getting this error message when I run the macro:
Run-time error '6': Overflow
I have two worksheets; Search and Data. The 'Data' worksheet contains two columns, column A with numbers I want to search through and column B with an alphanumeric value I want to copy and paste into the 'Search' worksheet when a number match is found. Because a number I am searching for can be listed an unknown number of times I want a macro to loop through to find all of the instances, copy the value to its immediate right and paste it into the 'Search' worksheet in cell D3 and going down a row for multiple instances of the number being found.
The number I am searching for is found in cell B3 on the 'Search' worksheet.
This is a sample of what the 'Data' worksheet looks like:
ID ISS_ID
108143 136KQV4
108143 173HBK3
108143 136KQX0
109728 7805JM1
109706 7805JM1
102791 23252T4
105312 6477LZ6
Here is the code that I have now:
Sub Acct_Search()
Dim searchResult As Range
Dim x As Integer
x = 3
' Search for "Activity" and store in Range
Set searchResult = Worksheets("Data").Range("A1:A3500").Find(What:=Worksheets("Search").Range("B3"), _
LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, _
SearchFormat:=False)
' Store the address of the first occurrence of this word
firstAddress = searchResult.Address
Do
' Set the value in the O column, using the row number and column number
Worksheets("Search").Cells(x, 4) = searchResult.Offset(0, 1).Value
' Increase the counter to go to the next row
x = x + 1
' Find the next occurrence of "Activity"
Set searchResult = Cells.FindNext(searchResult)
' Check if a value was found and that it is not the first value found
Loop While Not searchResult Is Nothing And firstAddress <> searchResult.Address
End Sub
When I Debug it points to the x = x + 1 line. Right now it is able to copy and paste the first value without issue but it is after that point that the error comes into play.
Your problem changed because you are not resetting the origin point of the search with the After:=... parameter of the Range.FindNext Method. Yes, you are passing in searchResult but it was not accepting it as the After:= parameter.
When I ran your code, I was thrown into an infinite loop due to the FindNext always finding the same second instance. This explains the integer coughing at being incremented above 2¹⁵. When it was changed to a long, that gave something else time to choke.
After I changed one line to definitively include the named parameter, everything cleared up.
Set searchResult = Cells.FindNext(After:=searchResult)
This was reproducible simply by adding/removing the parameter designation. It seems that the Cells.FindNext(searchResult) was finding Search!B3 and since that wasn't the firstAddress, it just kept looping on the same Search!B3. It wasn't until I forced after:=searchResult that the .FindNext adjusted itself. It's times like these I think fondly of my C/C++ days without this wallowing overhead.
I've gone through your code and added a With ... End With block that should discourage any questionable parentage.
Sub Acct_Search()
Dim searchResult As Range, firstAddress As String
Dim x As Long, ws As Worksheet
x = 3
Set ws = Worksheets("Search")
' Search for "Activity" and store in Range
With Worksheets("Data").Range("A1:A3500")
Set searchResult = .Find(What:=ws.Range("B3"), LookIn:=xlFormulas, After:=.Cells(.Rows.Count, .Columns.Count), _
LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
' Store the address of the first occurrence of this word
firstAddress = searchResult.Address
Do
' Set the value in the O column, using the row number and column number
ws.Cells(x, 4) = searchResult.Offset(0, 1).Value
' Increase the counter to go to the next row
x = x + 1
' Find the next occurrence of "Activity"
Set searchResult = .FindNext(After:=searchResult)
'Debug.Print searchResult.Address(0, 0, external:=True)
' Check if a value was found and that it is not the first value found
Loop While Not searchResult Is Nothing And firstAddress <> searchResult.Address
End With
Set ws = Nothing
End Sub
I've left the After:= parameter designation in although it is no longer needed.
Change
Dim x As Integer
to
Dim x As Long