I am trying to put the information from a worksheet into an array, using:
WBArray = ActiveSheet.Range(Cells(5, 1), Cells(end1, 29)).Value
But there are a couple of problems: first that the last 2 rows of my original range contain useless data. How could I remove these two rows as I pass them to array? is there a direct method like the one I am using?
Second, that my range starts at row 5, but since it has to go through old files, that number might be different. Is there a way I can make a floating reference, so it changes based on where the data I want begins? (for example, if it starts in row 7).
I already tried looping through each item, but that also does not seem to work.
Any ideas?
edited after OP's clarifications
you could use this function:
Function GetArray(sht As Worksheet) ', uselessRows As Long)
With sht
GetArray = .Range(.Columns(1).Find(what:="Identifier", lookat:=xlWhole, LookIn:=xlValues), _
.Cells(.UsedRange.Rows(.UsedRange.Rows.Count).Row - 6, 29)).Value
End With
End Function
and call it in your main sub as:
WBArray = GetArray(mySht)
where mySht is any valid worksheet reference like, for instance ActiveSheet
Maybe
Sub x()
Dim start1 As Long, end1 As Long, WBArray, r As Range
With ActiveSheet
Set r = .Columns(1).Find(What:="Identifier", After:=.Cells(.rows.Count,1), LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not r Is Nothing Then
start1 = r.Row
end1 = .Range("A" & Rows.Count).End(xlUp).Row - 2
WBArray = .Range(Cells(start1, 1), Cells(end1, 29)).Value
Else
MsgBox "Identified not found"
End If
End With
End Sub
Related
I have a macro which performs a vlookup by taking the vendor name in column J and looks for the vendor number in my table array of my vlookup in column C and D. However when I run the macro, something goes visibly wrong with my vlookup. Please see the formula inside the picture attached. Apparently, the part of my table array in my vlookup does not work properly. Actually, I would like that my vlookup returns me a fixed table array (I mean with absolute reference and dollar) from point of origin C5 and as limit point the last row in column D (I mean the limit of my table array should be the last row of column D).
Please see my VBA code below, it seems that this part of my VBA code inside my vlookup is wrong
: C4" & LastRow & "
Thanks a lot for your help.
Xavi
Sub insertvlookuptogetmyvendornumber()
Dim LastRow As Integer
LastRow = Range("D" & Rows.Count).End(xlUp).Row
PenultimateLastRow = Range("J" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Range("I4").Select
ActiveCell.FormulaR1C1 = "Vendor number"
Range("I5").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[1],R5C3:C4" & LastRow & ",2,0)"
Selection.AutoFill Destination:=Range("I5:I" & PenultimateLastRow), Type:=xlFillDefault
End Sub
As per my comment I would maintain a historic table of names and numbers. I would initially read this into a dictionary and then loop the appropriate columns of the pivottable updating the dictionary value if the name exists. If the name doesn't exist then add the name and number to the dictionary. At the end write it all back out the historic table.
The historic table is your current table where you are trying to do VLookup. In this case, that table would only contain matched pairs which have new values added to it from pivottable, or existing values updated.
To re-iterate, your table on the right, columns I & J should only have matched pairs in it to start with. Hardcoded.
This assumes no subtotal/total rows within pivottable body, though these can be excluded, if present, with an update to the code.
Option Explicit
Public Sub UpdateReferenceTable()
Dim lastRow As Long, dict As Object, ws As Worksheet, pvt As PivotTable, i As Long
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set pvt = ws.PivotTables("PivotTable1")
Set dict = CreateObject("Scripting.Dictionary")
With ws
lastRow = .Cells(.Rows.Count, "I").End(xlUp).Row
End With
Dim initialDictData(), pivotTableUpdates()
initialDictData = ws.Range("I9:J" & lastRow).Value
For i = LBound(initialDictData, 1) To UBound(initialDictData, 1)
dict(initialDictData(i, 2)) = initialDictData(i, 1)
Next
Dim names(), vendorNumbers()
names = Application.Transpose(pvt.PivotFields("Name 1").DataRange.Value)
vendorNumbers = Application.Transpose(pvt.PivotFields("Vendor Number").DataRange.Value)
For i = LBound(names) To UBound(names)
If names(i) <> vbNullString Then
If dict.exists(names(i)) Then
dict(names(i)) = vendorNumbers(i)
Else
dict.Add names(i), vendorNumbers(i)
End If
End If
Next
ws.Range("I9").Resize(dict.Count, 1) = Application.Transpose(dict.items)
ws.Range("J9").Resize(dict.Count, 1) = Application.Transpose(dict.Keys)
End Sub
Data:
I have the below loop in VBA:
For i = 1 To Range("B" & "65536").End(xlUp).Row Step 1
Companies = Range("A" & i).Value
Next i
MsgBox Companies 'Output Company Name (One time)
So above loop iterates through rows, that all have a company name in Column "A". I want to add all these company names to an array, so I can print them all out later on (after the loop)
How can I dynamically add the Companies value to an array, and use it later on?
you don't need Loop
Just try this :
Dim DirArray As Variant
DirArray = Range("A1:A5000").Value
I think something like this is what you're looking for.
Sub tgr()
'Declare variables
Dim ws As Worksheet
Dim Companies As Variant
Dim i As Long
'Always fully qualify which workbook and worksheet you're looking at
Set ws = ActiveWorkbook.ActiveSheet
'You can assing a Variant variable to the value of a range
' and it will populate the variable as an array if there
' is more than one cell in the range
'Note that I am going off of column B as shown in your original code,
' and then using Offset(, -1) to get the values of column A
Companies = ws.Range("B1", ws.Cells(ws.Rows.Count, "B").End(xlUp)).Offset(, -1).Value
If IsArray(Companies) Then
'More than one company found, loop through them
For i = LBound(Companies, 1) To UBound(Companies, 1)
MsgBox "Company " & i & ":" & Chr(10) & _
Companies(i, 1)
Next i
Else
'Only one company found
MsgBox Companies
End If
End Sub
If you need an array, which is increased every time and still saves its contents, something like this should work:
Option Explicit
Public Sub TestMe()
Dim i As Long
Dim companies() As Variant
ReDim companies(0)
For i = 1 To 20
ReDim Preserve companies(UBound(companies) + 1)
companies(UBound(companies)) = Range("A" & i)
Next i
End Sub
If you need simply need to take the values to array, then the answer of #Leo R. is probably the easiest way to achieve it.
I have a dirty database where the names of each individual are written in different ways and I cannot group them.
I would like to create a macro to find and replace the names in the database using a two column list.
I have found the following code, but I´m having trouble understanding it, so cannot adapt it:
Dim Sht As Worksheet
Dim fndList As Integer
Dim rplcList As Integer
Dim tbl As ListObject
Dim myArray As Variant
Dim Rng As Range
'Create variable to point to your table
Set tbl = Worksheets("How to").ListObjects("Table2")
'Create an Array out of the Table's Data
Set TempArray = tbl.DataBodyRange
myArray = Application.Transpose(TempArray)
'Designate Columns for Find/Replace data
fndList = 1
rplcList = 2
'Loop through each item in Array lists
For x = LBound(myArray, 1) To UBound(myArray, 2)
'Loop through each worksheet in ActiveWorkbook (skip sheet with table in it)
For Each Rng In Worksheets("xxxxxxxxxx").Activate
If Rng.Name <> tbl.Parent.Name Then
Rng.Cells.replace What:=myArray(fndList, x), Replacement:=myArray(rplcList, x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
End If
Next Rng
Next x
End Sub
I have adjusted your code which you can see below; couple notes:
1- Using Option Explicit is always a good idea
2- If you put the array loop inside the sheet loop, you only have to perform the sheet name check n times (n=number of sheets in workbook), if you put the sheet loop inside the array loop you would have to perform the sheet name check n*x times (x = number of items in your array)...
3- You didn't specify, but I assumed that your Table1 was structured vertically with the lookup value in the first column and the replacement value in the 2nd- so there is no need to transpose your array; if your Table1 is in fact horizontal then you would need to adjust this code...
Public Sub demoCode()
Dim sheetName As String
Dim tableRange As Range
Dim myArray() As Variant
Dim wsCounter As Long
Dim rowCounter As Long
'Store name of sheet with lookup table
sheetName = "How to"
'Create an Array out of the Table's Data
Set tableRange = ThisWorkbook.Sheets(sheetName).ListObjects("Table1").DataBodyRange
myArray = tableRange
'Loop through each sheet
For wsCounter = 1 To ThisWorkbook.Sheets.Count
With ThisWorkbook.Sheets(wsCounter)
'Test to make sure the sheet is not the sheet with the lookup table
If .Name <> sheetName Then
'Loop through each item in lookup table
For rowCounter = LBound(myArray, 1) To UBound(myArray, 1)
'Replace any cells that contain whats in the first column of the lookup table, with whats in the 2nd column..
.Cells.Replace What:=myArray(rowCounter, 1), Replacement:=myArray(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End If
End With
Next
End Sub
Hope this helps,
TheSilkCode
so to answer your second question, basically what you would need to do is remove the sheet loop (which you have done), and then the part you're missing is you also need to specify you want the code to perform the replace on just the cells within the target range, instead of performing it on the cells within the sheet (which would be all the cells)... see below for example:
Public Sub demoCode_v2()
Dim tableRange As Range
Dim myArray() As Variant
Dim rowCounter As Long
Dim targetRange As Range
'Create an Array out of the Table's Data
Set tableRange = ThisWorkbook.Sheets(sheetName).ListObjects("Table1").DataBodyRange
myArray = tableRange
'Select target range
Set targetRange = Application.InputBox("Select target range:", Type:=8)
'Loop through each item in lookup table
For rowCounter = LBound(myArray, 1) To UBound(myArray, 1)
'Replace any cells in target range that contain whats in the first column of the lookup table, with whats in the 2nd column..
targetRange.Cells.Replace What:=myArray(rowCounter, 1), Replacement:=myArray(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End Sub
Hope this helps,
TheSilkCode
Using a slight adjustment of TheSilkCode code you could loop through a worksheet as follows:
Option Explicit
Public Sub pDemo()
Dim vMappingTable() As Variant
Dim rowCounter As Long
'1) Create an Array out of the Old to New Name mapping
vMappingTable = wksMappings.ListObjects("tbl_Mapping").DataBodyRange
'2) Loops through desired sheet and replaces any cells that contain the first column val, with the 2nd column val...
With wksToReplace.Range("X:X")
For rowCounter = LBound(vMappingTable, 1) To UBound(vMappingTable, 1)
.Cells.Replace What:=vMappingTable(rowCounter, 1), Replacement:=vMappingTable(rowCounter, 2), LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next
End With
End Sub
Note: you can define names of table via the Name manager (Ctrl+F3) and you can set the name of worksheets in your project in the properties in the VBA editor which I have done here or use the default names/and or path.
I want to select a array of sheets using the Sheets(Array()) method.
The sheets I want to select are named in the cells of my workheet Printlist.
The sheetnames are listed form column D to K.
Not all cells are filled so if I use the folowing function it errors on the rows with blank cells. How can I avoid this error:
This is what the sheet looks like:
And this is the code
Sub PDF_maken()
Dim ws As Worksheet
Dim LR As Long
Dim r As Range
Dim Mypath As String
Dim strarray As String
Set ws = ActiveWorkbook.Worksheets("Printlijst")
LR = ws.Cells(Rows.Count, 1).End(xlUp).Row
For Each r In ws.Range("B20:B20").Cells
If Not IsEmpty("B" & r.Row) Then
Mypath = ws.Range("B" & r.Row).Text
colCheck = 4
Do Until Cells(r.Row, colCheck) = ""
strarray = strarray & IIf(colCheck > 4, ",") & """" & Cells(r.Row, colCheck).Value & """"
colCheck = colCheck + 1
Loop
ActiveWorkbook.Sheets(strarray).Select
ActiveWorkbook.SelectedSheets.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=Mypath & ws.Range("C" & r.Row).Text & ".pdf", _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
End If
Next r
End Sub
You can use a regular array rather than the Array() function to create the array. Then you can loop through the cells that contains sheet names and only add them if they're not blank. Here's an example.
Sub PDF_maken()
Dim ws As Worksheet
Dim lLastRow As Long
Dim rMap As Range
Dim sPath As String
Dim aSheets() As String
Dim lShCnt As Long
Dim rSh As Range
Set ws = ActiveWorkbook.Worksheets("Printlist")
lLastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For Each rMap In ws.Range("B2:B" & lLastRow).Cells
'Make sure there's a path
If Not IsEmpty(rMap.Value) Then
sPath = ws.Range("B" & rMap.Row).Text
're-dimension an array to hold all the sheet names
ReDim aSheets(1 To Application.WorksheetFunction.CountA(rMap.Offset(, 2).Resize(1, 8)))
'reset the counter
lShCnt = 0
'loop through all the cells that might have a sheet name
'and add them to the array
For Each rSh In rMap.Offset(, 2).Resize(1, 8).Cells
If Not IsEmpty(rSh.Value) Then
lShCnt = lShCnt + 1
aSheets(lShCnt) = rSh.Text
End If
Next rSh
ActiveWorkbook.Sheets(aSheets).Select
ActiveSheet.ExportAsFixedFormat xlTypePDF, sPath & rMap.Offset(0, 1).Text & ".pdf"
End If
Next rMap
ws.Select
End Sub
If you get Error 9: Subscript Out of Range there are three things to check:
The first one is that you spelled a sheet name wrong. Make sure there are no spaces or other funny business that makes it look like you have a good sheet name and you don't.
Next, make sure you qualify all of your references back to the workbook level. Depending on where your code is, unqualified references can point to different places. Don't ever use Sheets(). Always use ThisWorkbook.Sheets() or some other workbook reference. That will make sure you're not trying to access a sheet in a workbook that you didn't intend to.
Finally, you can get that error if you pass numbers to Sheets because your sheet names are numbers. Or rather they look like numbers, but they're really text. sheets(array(1234,4567)).select is different than sheets(array("1234","4567")).select. You have to pass strings to Sheets or you'll get that error. Kind of. You can pass numbers, but it will Select the sheets based on their index numbers rather than their names. That's why you have to be extra careful when your sheet names look like numbers.
Do a similar loop,
something like
colCheck=4
do until cells(r.row,colCheck)=""
strArray=strarray & iif(colCheck>4,",","") & cells(r.row,colCheck).value
colCheck=colCheck+1
loop
then you'll get something like a,b,c I've not tested this, so may need some tweaking. I'll revisit in a moment.
So I have found and modified a macro that fits my needs, however there is one limitation. I am building a macro to search medical payment data for specific diagnosis codes and procedure codes. In the project I am currently working on there are only 14 diagnosis codes, so I was able to put this directly into the VBA. However, there are over 800 procedure codes which I cannot fit into the VBA.
I was able to do a seperate VBA step to bring in a table with this data, but I cant seem to get it set up to search against the table. But that being said, what is the best way to run this VBA search for such a large number of items?
Sub PROCEDURE_1_search()
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim Rng As range
Dim I As Long
MySearch = Array("412", "4100", "4101", "4102", "4103",...) <-- have over 800
With Sheets("All Claims by Date of Service").range("G5:G55000")
For I = LBound(MySearch) To UBound(MySearch)
Set Rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
With ActiveSheet.range("B" & Rng.Row & ":O" & Rng.Row)
.Font.ColorIndex = 1
.Interior.ColorIndex = 4
End With
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
I might be coming up with an answer and not asking the right questions. Please let me know if there is anything I can clarify and thank you in advance for any assistance.
-Ryan
For searching an array, I would recommend you to dump the data into a variant Array instead of iterating through ranges. That way it reduces the traffic of going back on forth on the code and sheet - specially formatting. Formatting is anyway expensive, in your case it seems to cost you a moon..
So here is how it goes by steps: (not the code - if you need a code take a look at these samples.).
Transpose the data into a variant array
Search as you desire in VBA code
Dump the databack in the location (range)
Format (range)
In your example you could use AutoFilter like this to highlight rows from columns B to O where G falls between 4101-4103 in a single shot (ie four criteria match a single conditon). A minor adaption would be to call this code block for different criteria such as a standaline 412 etc.
Sub Smaller()
Dim rng1 As Range
Set rng1 = Sheets("All Claims by Date of Service").Range("$G$5:$G$55000")
With rng1
.AutoFilter Field:=1, Criteria1:=">=4100", Operator:=xlAnd, Criteria2:="<=4103"
.Offset(0, -6).Resize(rng1.Rows.Count, 14).Font.ColorIndex = 1
.Offset(0, -6).Resize(rng1.Rows.Count, 14).Interior.ColorIndex = 4
End With
Sheets(rng1.Parent.Name).AutoFilterMode = False
End Sub