I have not used VBA in a while so I'm a bit rusty. Seeking help.
The task:
I need to pull all unique value from a given range in a closed workbook, into my sub's workbook.
I'm thinking of calling a function that returns an array of my unique non-blank values. because I need to know the quantity of unique values to insert the right amount of lines in the main workbook. Can't juts copy-paste the values. And also because I need to remove the duplicates.
Some relevant code bits up to know:
Sub PullACParts()
Dim FullFilePath As String
Dim arrPartList() As String
FullFilePath = "C:\Users\[...]file1.xlsx"
arrPartList() = GetValues(FullFilePath)
and that calls:
Function GetValues(path as string) as Variant
Dim arrValues() As String
Dim arrUnikVals As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
Dim src As Workbook
' OPEN THE SOURCE EXCEL WORKBOOK IN "READ ONLY MODE".
Set src = Workbooks.Open(FullFilePath, True, True)
' GET THE TOTAL ROWS FROM THE SOURCE WORKBOOK.
Dim iTotalRows As Integer
TotalRows = src.Worksheets("Sheet1").Range("D1:D" & Cells(Rows.Count, "D").End(xlUp).Row).Rows.Count
' COPY NON-BLANK DATA FROM SOURCE FILE COLUMN-4 TO ARRAY.
Dim iCnt As Integer ' COUNTER.
Dim ArrDim As Long: ArrDim = 0
For iCnt = 4 To TotalRows
If src.Worksheets("Sheet1").Range("D" & iCnt).Value <> "" Then
arrValues(ArrDim) = src.Worksheets("Sheet1").Cells(4 & iCnt).Formula 'FAILS HERE
ArrDim = ArrDim + 1
End If
Next iCnt
' CLOSE THE SOURCE FILE.
src.Close False ' FALSE - DON'T SAVE THE SOURCE FILE.
Set src = Nothing
' Remove Duplicates
arrUnikVals = RemoveDupesColl(arrValues)
GetValues = arrUnikVals
ErrHandler:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Function
It fails when I try loading the array. Says "arrValues(ArrDim) =
I tried a few different things but just can't figure it out.
Thanks in advance for the help!!
You don't need to loop this. First set your variable types.
Dim arrValue as Variant, lr as long
Once this is a variant you can simply grab the array from the range in one go by transposing it:
lr = src.Worksheets("Sheet1").range("D" & rows.count).end(xlup).row
Application.transpose(src.Worksheets("Sheet1").range("D4:D" & lr))
If you need to loop the values in the array later you simply do something like this:
Dim X as long
For X = lbound(arrValue) to ubound(arrValue)
msgbox arrValue(X)
next
I do however note in your question you say you want to pull data from a CLOSED workbook but your code is opening the book. There are ways to pull data direct from a closed book but it would be difficult because you don't know how many rows it will be without opening the book. If you absolutely have to leave the book closed then post back.
I also note you are using cells(4 & iCnt) to try and populate the array, you do know that is just the cell counting from left to right then row to row? in other words cells(2) is B1 and cells(16386) is B2. You should use cells(Row,Column) I think from what you have said you want to increment the row but if not then post back, we simply double transpose if it's across columns instead of rows.
Related
So I made a simple VBA macro to run over ~7000 rows of data - the idea is that .Find finds the cells which contain "1" in column G, so that it can store the row number in an array which I shall later throw back to another sub
Unfortunately the code takes too long to run - it begs the question, have I created an infinite loop in my code? Or is asking it to loop a .find operation over 7000 cells too much for vba to handle at a reasonable speed? (i.e. do I need to improve efficiency in areas?)
Option Explicit
Public Sub splittest()
Dim sheet As Object, wb As Workbook
Dim rangeofvals As Range
Dim pullrange As Variant
Dim c As Long
Dim dynarr() As Variant
Dim xvalue As Long
Dim firstaddress As Variant
Dim count As Long
Set wb = ThisWorkbook
Set sheet = wb.Sheets("imported d")
Set rangeofvals = Range("G1:G6939")
'need to set pull range at some later point
Call OptimizeCode_Begin 'sub which turns off processes like application screen updating
xvalue = 1
ReDim dynarr(3477) 'hardcoded, replace with a countif function at some point
count = 0
With wb.Sheets("imported d").Range("G1:G6939")
c = rangeofvals.Find(xvalue, LookIn:=xlFormulas).Row
If c >= 0 Then
dynarr(count) = c
' MsgBox firstaddress
Do
' MsgBox c
c = rangeofvals.FindNext(Cells(c, 7)).Row
dynarr(count) = c 'apparently redim preserve would be slower
Loop While c >= 0
End If
Call OptimizeCode_End 'sub which turns back on processes switched off before
End With
End Sub
If you know the column is G and all the data is contiguous, then just loop through the rows and check the cell value directly:
Dim rows As New Collection
Dim sheet As Worksheet
Dim lastRow, i As Integer
Set sheet = ThisWorkbook.Sheets("imported d")
lastRow = sheet.Cells(1,7).CurrentRegion.Rows.Count
For i = 1 to lastRow
If (sheet.Cells(i,7).Value = 1) Then
rows.Add i
End If
Next
Unclear how the data is being used in the other sub but collection is definitely more efficient storage object for adding iteratively when the total item count is indeterminate. If you want to convert to an array then you can do so efficiently afterward since the collection tells you the item count. I'm not really sure why you would need an array specifically but I'm not going to tell you not to without seeing the client sub. Also note that the declaration of sheet was changed from Object to Worksheet since it is better to use the specific data type if possible.
...yep it was an infinite loop.
the line:
Loop While c >= 0
caused it as there is never an occasion c is less than 0 - back to the drawing board for me!
I'm currently working on a project on VBA that requires multiple manipulation on data.
So, the main idea of this will be to get the data that I have on "Q1" and paste it 4 times on A (starting at the first blank cell), after that, take the data from "Q2" and do the same until there is no more data on the "Q" column. After there is no more data, the process should stop.
Later on I may need to modify the process, so the value gets pasted only 2 or 3 times instead of 4.
Something like this:
Column Q data:
Expected result:
I think this will do what you want:
Option Explicit
Sub Transpose_Multiplied()
Dim Number_Of_Repetitions As Integer
Dim Input_Column As String
Dim Output_Column As String
' -----------------------------------------------------------
' These are the control variables ....
Number_Of_Repetitions = 4
Input_Column = "Q"
Output_Column = "A"
' -----------------------------------------------------------
Dim WSht As Worksheet
Dim Cell As Range
Dim LastACell As Long
Dim i As Integer
Set WSht = ActiveWorkbook.ActiveSheet
For Each Cell In WSht.Range(Input_Column & "2:" & Input_Column & WSht.Cells(WSht.Rows.Count, Input_Column).End(xlUp).Row)
For i = 1 To Number_Of_Repetitions
LastACell = WSht.Cells(WSht.Rows.Count, Output_Column).End(xlUp).Row
If LastACell = 1 And WSht.Cells(LastACell, Output_Column).Value = vbNullString Then
WSht.Cells(LastACell, Output_Column).Value = Cell.Value
Else
WSht.Cells(LastACell + 1, Output_Column).Value = Cell.Value
End If
Next
Next
End Sub
So, I open up my workbook and leave it open on the Worksheet where the data to be processed is. Then I run the macro from my PERSONAL.XLSB:
I'm trying to take a rough list of data, then copy it into a pre-formatted, organized form. To do this, I have the rough list set up so that each item on the list is numbered in order, no matter if there are spaces between items. The macro I am trying to make will take that rough list and copy it to the form without any spaces. Bear with me, I have been trying to teach myself Visual Basic, so the code I have may be... messy. Currently, the problem that I am having is that I get an overflow on i = i + 1.
Sub Print_Sheet_Populate()
'
' Print_Sheet_Populate Macro
' Takes Items from Raw Data sheet and puts them in Print Sheet sheet.
'
'
Dim wsS1 As Worksheet
Dim wsS2 As Worksheet
Dim ending As Long
Dim copy() As Long
Dim i As Long
Set wsS1 = Sheets("Raw Data")
Set wsS2 = Sheets("Print Sheet")
With wsS1.Range("A:A") 'To copy the item numbers in the rough data to an array
i = 1
Set c = .Find(i, LookIn:=xlValues)
If Not c Is Nothing Then
ReDim copy(i)
copy(i - 1) = c.Value
Do
i = i + 1
ending = i
Loop While Not c Is Nothing
End If
End With
With wsS2.Range("A24:A324") 'To paste the data from the array to the form
i = 1
If Not i = ending Then
Do
Worksheets("wsS2").Range("A" & i).Value = copy(i - 1)
i = i + 1
Loop While Not c Is Nothing
End If
End With
End Sub
Taken from Range.Find Method (Excel):
When the search reaches the end of the specified search range, it
wraps around to the beginning of the range. To stop a search when this
wraparound occurs, save the address of the first found cell, and then
test each successive found-cell address against this saved address.
I am trying to copy the value of multiple non-contiguous ranges into an array. I wrote code like this:
summaryTempArray = .range("A2:D9,A11:D12,A14:D15").Value
But it copies only the first part (A2:D9). Then, I tried the following and I get the error - "Method Union of Object _Global Failed" - is there any mistake in the way that I am using union?
summaryTempArray = Union(.range("A2:D9"), .range("A11:D12"), .range("A14:D15")).Value
Don't know what was wrong with your union, but it would have created the same range, which you stated in your first attempt.
The problem is, you have now multiple areas. Which you can, and as far as I know, has to address now.
Here is an example, which will resolve in an array of all areas, without adding each cell individually, but adding each area individually to the summary array:
Public Sub demo()
Dim summaryTempArray() As Variant
Dim i As Long
With Tabelle1
ReDim summaryTempArray(1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count)
For i = 1 To .Range("A2:D9,A11:D12,A14:D15").Areas.Count
summaryTempArray(i) = .Range("A2:D9,A11:D12,A14:D15").Areas(i)
Next i
End With
End Sub
Hope this helps.
I believe Jook's solution is as good as you are going to get if it is important to get the source ranges into an array. However, I think the solution should include instructions on extracting values from a ragged array. This is not difficult but the syntax is obscure.
I cannot get your Union statement to fail either. I assume there is something about the context that causes the failure which I cannot duplicate.
The code below shows that the two ranges are the same and that only the first sub-range is loaded to an array as you reported. It finishes with an alternative approach that might be satisfactory.
Option Explicit
Sub Test()
Dim CellValue() As Variant
Dim rng As Range
With Worksheets("Sheet1")
Set rng = .Range("A2:D9,A11:D12,A14:D15")
Debug.Print rng.Address
Set rng = Union(.Range("A2:D9"), .Range("A11:D12"), .Range("A14:D15"))
Debug.Print rng.Address
' The above debug statements show the two ranges are the same.
Debug.Print "Row count " & rng.Rows.Count
Debug.Print "Col count " & rng.Columns.Count
' These debug statements show that only the first sub-range is included the
' range counts.
CellValue = rng.Value
Debug.Print "Rows " & LBound(CellValue, 1) & " to " & UBound(CellValue, 1)
Debug.Print "Cols " & LBound(CellValue, 2) & " to " & UBound(CellValue, 2)
' As you reported only the first range is copied to the array.
rng.Copy Destination:=Worksheets("Sheet2").Range("A1")
' This shows you can copy the selected sub-ranges. If you can copy the
' required data straight to the desired destination, this might be a
' solution.
End With
End Sub
I had the same problem & tried a few methods without success until I hit on this:-
dim i as integer
Dim rng1 as range
Dim str as string
dim cels() as string
Set rng1 = sheet1.Range("A2:D9,A11:D12,A14:D15")
str = rng1.address(0,0)
cels() = split(str, ",") '<--- seems to work OK
for i = 0 to 2
Debug.Print cels(i)
Next i
I would be interested if this is an "incorrect" conversion method.
It is possible to create a multi dimensional array from non concurrent cell ranges. What I did was use a bit of the code above for the range copy mechanic I learned 2 things; that with that method you can refer to the actual cells and not just the data and you can also move and preserve order with it. In my personal project we have to use some excel files to fill out calibration data. It runs the calculations and produces a report of calibration record for our files to refer to later. These stock files are boring! I wanted to spruce it up a bit and color most of the documents empty cells depending on if the calibration passed or not. The files separate the individual check steps so the ranges I wanted to look through were not always adjacent. What I came up with is to use the copy function below to create a new sheet and paste all the non-concurrent ranges into one nice new set of concurrent ones and then have my array look at the new sheet to draw my table. I have it run the lookup I needed and then get rid of the now useless sheet.
Public Sub ColorMeCrazy()
' First Declare your variables that you will need line notes will be added to all the ones for just the array problem
Dim chkarray As Variant
Dim i As Integer ' for the array lookup loop
Dim j As Integer ' also for the array lookup loop
Dim chk1 As Boolean
Dim chk2 As Boolean
Dim cpyrange As Range ' the non-concurrent range collector haha.
Dim cz As Range
chk2 = True
Set cz = Worksheets("AN_PRM-36").Range("A1:I1,C2:I2,I3:I35,A30:H32,D33:H35,C34:C35,A36:E36,A22:H23,D24:H24,A16:H16,A8:H9,D10:H10")
' the next item below sets the ranges i wish to use. see that they arent all just right next to eachother.
Set cpyrange = Worksheets("AN_PRM-36").Range("G7:H7,G15:H15,G21:H21,G28:H29")
' this is the new sheet i made to create the array with
Sheets.Add.Name = "AN_PRM-36tmp"
' the data gets coppied to the new sheet but now its all together
cpyrange.Copy Destination:=Worksheets("AN_PRM-36tmp").Range("A1")
' now i tell the array i want it to use the data on the new sheet
chkarray = Worksheets("AN_PRM-36tmp").Range("A1:B5")
'this was my look up for the nonsense that i wanted to do later
For i = LBound(chkarray, 1) To UBound(chkarray, 1)
For j = LBound(chkarray, 2) To UBound(chkarray, 2)
Debug.Print chkarray(i, j)
If chkarray(i, j) = "Pass" Then
chk1 = True
Else
chk2 = False
End If
Next
Next
If chk1 = True And chk2 = True Then
cz.Interior.ColorIndex = 4
Else
cz.Interior.ColorIndex = 3
End If
' this last bit will get rid of the new sheet and not ask you are you sure you want it gone.
Application.DisplayAlerts = False
Sheets("AN_PRM-36tmp").Delete
Application.DisplayAlerts = True
End Sub
In Excel I have a column of words. I believe you call words "strings" in the programming world.
Row by row, I need to take each word in the column and put single inverted commas around it.
For example, if the word in the cell is dog, I need to change it to 'dog'.
I am trying to write a macro to do this, but I am already running into problems with the very first part of the vba code, which is just to import the column of words into vba from the excel spreadsheet.
My code is below. The Error message says "subscript out of range", but as you can see I have dimmed the array. What am I doing wrong? Thanks.
Sub putquotes()
Dim sym(1 To 162) As String
For i = 1 To 162
sym(i) = Worksheets("sheet1").Cells(i + 1, 1)
Next i
End Sub
I think your issue is your sheet1 name which should probably be Sheet1
I would use something like this which will run on the first worksheet (see Set ws = Sheets(1))
Note that the third sheet would be Set ws = Sheets(3), or you could use Set ws = Sheets("Sheet1") if you did have such a sheet
This code:
will run independent of the sheet that is selected
looks from the first to last used cell in column A (rather than hard-coding 162 rows)
uses variant arrays rather than ranges for speed
adds a double '' to ensure the first is visible :)
Sub PutQuotes()
Dim ws As Worksheet
Dim varList
Dim rng1 As Range
Dim lngCnt As Long
Set ws = Sheets(1)
Set rng1 = ws.Range(ws.[a1], ws.Cells(Rows.Count, "A").End(xlUp))
varList = rng1.Value2
For lngCnt = 1 To UBound(varList)
If Len(varList(lngCnt, 1)) > 0 Then _
varList(lngCnt, 1) = "''" & varList(lngCnt, 1) & "'"
Next
'dump updated array back over range
rng1.Value2 = varList
End Sub
You don't have a sheet named "Sheet1". Either:
This code lives in a standard module in the workbook with the data and you've renamed the
sheet, or
The code lives in another workbook and you haven't properly qualified your Worksheets property
I'm going to assume the latter. When you use collection properties like Worksheets or Cells, Excel makes assumptions on who the parent is. An unqualified Worksheets call in a standard module will assume
ActiveWorkbook.Worksheets()
An unqualified Worksheets call in the ThisWorkbook module will assume
ThisWorkbook.Worksheets()
To check where the problem is, add this line to your code
Debug.Print Worksheets("Sheet1").Parent.Name
That will tell you which workbook Excel is using and may be different than you want.
To avoid bad guessing, it's best to fully qualify your references. For instance, if you're opening the workbook with the data, it might look like this
Sub putquotes()
Dim wb As Workbook
Dim sym(1 To 162) As String
Dim i As Long
Set wb = Workbooks.Open("Path\Name")
For i = 1 To 162
sym(i) = wb.Sheets("Sheet1").Cells(i + 1, 1)
Next i
End Sub
Holding that wb reference is an easy way to qualify the reference. If you're not opening a separate file in code, you can just qualify explicitly like
ThisWorkbook.Worksheets("Sheet1")
ActiveWorkbook.Worksheets("Sheet1")
Workbooks("Mybook.xlsx").Worksheets("Sheet1")
A better way to read cell values into an array is like this
Sub putquotes()
Dim wb As Workbook
Dim sym As Variant
Dim i As Long
Set wb = Workbooks.Open("Path\Name")
sym = wb.Sheets("Sheet1").Range("A2").Resize(162, 1).Value
For i = LBound(sym, 1) To UBound(sym, 1)
Debug.Print "'" & sym(i, 1) & "'"
Next i
End Sub
That will give you a two-dimensional-base-1 array, which you may not like, but it's faster than reading them in one at a time.
I believe you want something like this...
Public Sub DoQuotes()
Dim iRow As Integer
Dim Result() As String
iRow = 1
Do While Not IsEmpty(Sheet1.Cells(iRow, 1))
ReDim Preserve Result(iRow - 1)
Result(iRow - 1) = "'" & Sheet1.Cells(iRow, 1) & "'"
iRow = iRow + 1
Loop
For Each x In Result
MsgBox (x)
Next x
End Sub
However, bear in mind that Excel will treat the first quote as a text delimiter so it whilst the value in the array is 'something' it will look like something' in Excel.
Just a general aside point, try to avoid calls to Worksheets() instead use the strongly typed Sheet1 object - saves all sorts of future pain if the worksheets get renamed. You can see what the sheets are "really" called in the vba editor. It will say something like Sheet1(MyWorksheet)