How do you correctly save the reference to a certain cell, like
Dim x As WHAT_TYPE_?
x = location_of_cell_in_memory
instead of activating it?
I don't want to iterate by activating cells (.Select or .Activate) and then using offset to move up or down. This should be done without anything happening on the screen, just retrieving and assigning values in the background, so the user can't click somewhere on the screen and ruin the script.
Or
do I really have to define some Pair-Datatype (x,y) myself and using that as Cell-representation?
Or
as a triple (sheet, x, y)?
I'm not even sure if that is even possible in VBA, I come from Java.
You don't have to activate or select a cell to assign a value. The value property can be read or written directly, given the proper object (Range or Cell, etc.). You can initialize a Range variable and let that hold the cell address you want to access later on.
The above said, if you just want to assign values over an iteration of cells, there's no need to really assign a dynamic range reference and use offset. A simple loop would do. See following code and example.
Sub IterateExample()
'Initialize variables.
Dim wb As Workbook
Dim ws As Worksheet
Dim x As Integer, y As Integer, i As Integer, j As Integer
' Assign to object.
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
' Assign values.
x = 10
y = 10
Application.ScreenUpdating = False 'Hide updates from viewer/user.
' Simple iteration.
For i = 1 To x
For j = 1 To y
'i is row index, j is column index.
ws.Cells(i, j).Value = i * j 'Use .Value directly, no need to .Select or .Activate
Next
Next
Application.ScreenUpdating = True 'Return to original setting.
End Sub
Result is simple enough:
However, if you really have to have a range reference that updates, a loop can also solve that, just re-assign the object inside the loop.
Sub OffsetExample()
'Initialize variables.
Dim wb As Workbook
Dim ws As Worksheet
Dim r As Range, i As Integer
'Assign to object.
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
'Assign range.
Set r = ws.Range("A1")
Application.ScreenUpdating = False 'Hide updates from viewer/user.
'Iteration of offset.
For i = 1 To 10
r.Value = i * i
Set r = r.Offset(1, 1) 'Move range reference 1 row down, 1 column right
Next
Application.ScreenUpdating = True 'Return to original setting.
End Sub
Result is as follows:
Related
I have a code that checks for each row if the cells in that row are zero (or empty). If a row applies to that rule the row is hidden. If not it remains visible.
The code works perfectly, however it is very very slow (takes about 40 seconds to complete each time I run it)..
I was wondering if anyone could see why my code is slow (or have an alternative which I can use which is faster than my current code)..
Sub hide()
' Macro hides all rows with position "zero" or "blank"
Dim wb As Workbook
Dim ws As Worksheet
Dim c As Range
Dim targetRange As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet 1")
Set targetRange = ws.Range("I10:N800")
targetRange.EntireRow.Hidden = False
For Each c In targetRange.Rows
If (WorksheetFunction.CountIf(c, "<>0") - WorksheetFunction.CountIf(c, "") = 0) And (WorksheetFunction.CountA(c) - WorksheetFunction.Count(c) = 0) Then
c.EntireRow.Hidden = True
End If
Next c
End Sub
The most time consuimng action in your code, is every time you perform actions on your worksheet, in your case when you hide each row (multiple times), here:
c.EntireRow.Hidden = True
In order to save time, every time your condition is met, just add tha range c to a MergeRng, and at the end (when you exit the loop), just hide the entire rows at once.
Try the code below:
Dim MergeRng As Range ' define range object
For Each c In targetRange.Rows
If (WorksheetFunction.CountIf(c, "<>0") - WorksheetFunction.CountIf(c, "") = 0) And (WorksheetFunction.CountA(c) - WorksheetFunction.Count(c) = 0) Then
If Not MergeRng Is Nothing Then
Set MergeRng = Application.Union(MergeRng, c)
Else
Set MergeRng = c
End If
End If
Next c
' hide the entire rows of the merged range at one time
MergeRng.EntireRow.Hidden = True
Right now I have a master excel workbook that employees use for data entry. Each of them downloads a copy to their desktops and then marks their progress on various entries by entering an "x" in a comlun next to the data they've finished. Each product has its own row with its respective data listed across that row. The master workbook is filled out throughout the quarter with new data for the products as it becomes available, which is currently updated on each individuals workbook by use of a macro that simply copies the range where the data is (see code below).
Sub GetDataFromClosedWorkbook()
'Created by XXXX 5/2/2014
Application.ScreenUpdating = False ' turn off the screen updating
Dim wb As Workbook
Set wb = Workbooks.Open("LOCATION OF FILE", True, True)
' open the source workbook, read only
With ThisWorkbook.Worksheets("1")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("F8:K25").Value = wb.Worksheets("1").Range("F8:K25").Value
End With
With ThisWorkbook.Worksheets("2")
' read data from the source workbook: (Left of (=) is paste # destination, right of it is copy)
.Range("V5:Z359").Value = wb.Worksheets("2").Range("V5:Z359").Value
End With
wb.Close False ' close the source workbook without saving any changes
Set wb = Nothing ' free memory
Application.ScreenUpdating = True ' turn on the screen updating
End Sub
The problem I'm having is this: every once and a while, I'll need to add a new product, which adds a row on the master (this is opposed to adding data, which is just added across the row). Sometimes this row is at the end, sometimes it's in the middle. As you can see from the code below, my VBA currently can't handle this row change as it is just copy/pasting from a predefined range. Each users's workbook does not pick up on this change in row # and thus the data in the colums becomes associated with the wrong rows. Normally, you could just copy the entire sheet and problem solved. The issue I have is that each user needs to be able to record their own process in their own workbook next to their data. Is there a way to code this so that a new row on the master sheet will be accounted for and added to all the others without erasing/moving the marks made by each user? I've been trying to find a way to make it "insert" rows if they're new in the master, as this would preserve the data, but can't figure it out. Also, due to security on the server at work- linking workbooks, etc is not an option. Does anyone have any thoughts on this?
One way to approach this problem would be using the Scripting.Dictionary Object. You could create a dictionary for both the target and source identifiers and compare those. I suppose you don't really need the Key-Value pair to achieve this, but hopefully this gets you on the right track!
Sub Main()
Dim source As Worksheet
Dim target As Worksheet
Dim dictSource As Object
Dim dictTarget As Object
Dim rng As Range
Dim i As Integer
Dim j As Integer
Dim idSource As String
Dim idTarget As String
Dim offset As Integer
Set source = ThisWorkbook.Sheets(2)
Set target = ThisWorkbook.Sheets(1)
offset = 9 'My data starts at row 10, so the offset will be 9
Set rng = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row)
Set dictSource = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictSource.Add Key:=cell.Value, Item:=cell.Row
Next
Set rng = target.Range("A10:A" & target.Cells(target.Rows.Count, "A").End(xlUp).Row)
Set dictTarget = CreateObject("Scripting.Dictionary")
For Each cell In rng
dictTarget.Add Key:=cell.Value, Item:=cell.Row
Next
i = 1
j = source.Range("A10:A" & source.Cells(source.Rows.Count, "A").End(xlUp).Row).Rows.Count
Do While i <= j
Retry:
idSource = source.Cells(i + offset, 1).Value
idTarget = target.Cells(i + offset, 1).Value
If Not (dictSource.Exists(idTarget)) And idTarget <> "" Then
'Delete unwanted rows
target.Cells(i + offset, 1).EntireRow.Delete
GoTo Retry
End If
If dictTarget.Exists(idSource) Then
'The identifier was found so we can update the values here...
dictTarget.Remove (idSource)
ElseIf idSource <> "" Then
'The identifier wasn't found so we can insert a row
target.Cells(i + offset, 1).EntireRow.Insert
'And you're ready to copy the values over
target.Cells(i + offset, 1).Value = idSource
End If
i = i + 1
Loop
Set dictSource = Nothing
Set dictTarget = Nothing
End Sub
I'm new to Excel VBA. I am trying to use a VBA function I found online that enables the user to use goalseek on multiple cells at a time. How do I call the function in a spreadsheet and how do I point to the cells that are supposed to be associated with the variables in the function (e.g. Taddr, Aaddr, gval). Do I have to write the cell values and ranges in the code itself and just run it that way?
Maybe I should redefine the function so that it takes these variables as input, so I can write a formula like =GSeekA(Taddr,Aaddr,gval)
Option Explicit
Sub GSeekA()
Dim ARange As Range, TRange As Range, Aaddr As String, Taddr As String, NumEq As Long, i As Long, j As Long
Dim TSheet As String, ASheet As String, NumRows As Long, NumCols As Long
Dim GVal As Double, Acell As Range, TCell As Range, Orient As String
' Create the following names in the back-solver worksheet:
' Taddr - Cell with the address of the target range
' Aaddr - Cell with the address of the range to be adjusted
' gval - the "goal" value
' To reference ranges on different sheets also add:
' TSheet - Cell with the sheet name of the target range
' ASheet - Cell with the sheet name of the range to be adjusted
Aaddr = Range("aaddr").Value
Taddr = Range("taddr").Value
On Error GoTo NoSheetNames
ASheet = Range("asheet").Value
TSheet = Range("tsheet").Value
NoSheetNames:
On Error GoTo ExitSub
If ASheet = Empty Or TSheet = Empty Then
Set ARange = Range(Aaddr)
Set TRange = Range(Taddr)
Else
Set ARange = Worksheets(ASheet).Range(Aaddr)
Set TRange = Worksheets(TSheet).Range(Taddr)
End If
NumRows = ARange.Rows.Count
NumCols = ARange.Columns.Count
GVal = Range("gval").Value
For j = 1 To NumCols
For i = 1 To NumRows
TRange.Cells(i, j).GoalSeek Goal:=GVal, ChangingCell:=ARange.Cells(i, j)
Next i
Next j
ExitSub:
End Sub
GSeekA is a Subprocedure, not a Function. Subprocedures cannot be called from worksheet cells like Functions can. And you don't want to convert GSeekA into a function. Functions should be used to return values to the cell(s) from which they're called. They shouldn't (and often can't) change other things on the sheet.
You need to run GSeekA as a sub. Now the problem becomes how you get user provided information into the sub. You can use InputBox to prompt the user to enter one piece of information. If you have too many, InputBox becomes cumbersome.
You can create areas in the spreadsheet where the user must enter information, then read from that area. That's how it's set up now. It's reading cells named asheet and tsheet. As long as those named ranges are present, the code works.
Finally, you can create a UserForm that the user will fill out. That's like putting a bunch of InputBoxes on one form.
Update Here's a simple procedure that you can start with and enhance.
Public Sub GSeekA()
Dim rAdjust As Range
Dim rTarget As Range
Dim dGoal As Double
Dim i As Long
'Set these three lines to what you want
Set rAdjust = Sheet1.Range("I2:I322")
Set rTarget = Sheet1.Range("J2:J322")
dGoal = 12.1
For i = 1 To rAdjust.Count
rTarget.Cells(i).GoalSeek dGoal, rAdjust.Cells(i)
Next i
End Sub
I already spent hours on this problem, but I didn't succeed in finding a working solution.
Here is my problem description:
I want to loop through a certain range of cells in one workbook and copy values to another workbook. Depending on the current column in the first workbook, I copy the values into a different sheet in the second workbook.
When I execute my code, I always get the runtime error 439: object does not support this method or property.
My code looks more or less like this:
Sub trial()
Dim Group As Range
Dim Mat As Range
Dim CurCell_1 As Range
Dim CurCell_2 As Range
Application.ScreenUpdating = False
Set CurCell_1 = Range("B3") 'starting point in wb 1
For Each Group in Workbooks("My_WB_1").Worksheets("My_Sheet").Range("B4:P4")
Set CurCell_2 = Range("B4") 'starting point in wb 2
For Each Mat in Workbooks("My_WB_1").Worksheets("My_Sheet").Range("A5:A29")
Set CurCell_1 = Cells(Mat.Row, Group.Column) 'Set current cell in the loop
If Not IsEmpty(CurCell_1)
Workbooks("My_WB_2").Worksheets(CStr(Group.Value)).CurCell_2.Value = Workbooks("My_WB_1").Worksheets("My_Sheet").CurCell_1.Value 'Here it break with runtime error '438 object does not support this method or property
CurCell_2 = CurCell_2.Offset(1,0) 'Move one cell down
End If
Next
Next
Application.ScreenUpdating = True
End Sub
I've done extensive research and I know how to copy values from one workbook to another if you're using explicit names for your objects (sheets & ranges), but I don't know why it does not work like I implemented it using variables.
I also searched on stackoverlow and -obviously- Google, but I didn't find a similar problem which would answer my question.
So my question is:
Could you tell me where the error in my code is or if there is another easier way to accomplish the same using a different way?
This is my first question here, so I hope everything is fine with the format of my code, the question asked and the information provided. Otherwise let me know.
5 Things...
1) You don't need this line
Set CurCell_1 = Range("B3") 'starting point in wb 1
This line is pointless as you are setting it inside the loop
2) You are setting this in a loop every time
Set CurCell_2 = Range("B4")
Why would you be doing that? It will simply overwrite the values every time. Also which sheet is this range in??? (See Point 5)
3)CurCell_2 is a Range and as JohnB pointed it out, it is not a method.
Change
Workbooks("My_WB_2").Worksheets(CStr(Group.Value)).CurCell_2.Value = Workbooks("My_WB_1").Worksheets("My_Sheet").CurCell_1.Value
to
CurCell_2.Value = CurCell_1.Value
4) You cannot assign range by just setting an "=" sign
CurCell_2 = CurCell_2.Offset(1,0)
Change it to
Set CurCell_2 = CurCell_2.Offset(1,0)
5) Always specify full declarations when working with two or more objects so that there is less confusion. Your code can also be written as
Option Explicit
Sub trial()
Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim Group As Range, Mat As Range
Dim CurCell_1 As Range, CurCell_2 As Range
Application.ScreenUpdating = False
'~~> Change as applicable
Set wb1 = Workbooks("My_WB_1")
Set wb2 = Workbooks("My_WB_2")
Set ws1 = wb1.Sheets("My_Sheet")
Set ws2 = wb2.Sheets("Sheet2") '<~~ Change as required
For Each Group In ws1.Range("B4:P4")
'~~> Why this?
Set CurCell_2 = ws2.Range("B4")
For Each Mat In ws1.Range("A5:A29")
Set CurCell_1 = ws1.Cells(Mat.Row, Group.Column)
If Not IsEmpty(CurCell_1) Then
CurCell_2.Value = CurCell_1.Value
Set CurCell_2 = CurCell_2.Offset(1)
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Workbooks("My_WB_2").Worksheets(CStr(Group.Value)).CurCell_2.Value
This will not work, since CurCell_2 is not a method of Worksheet, but a variable. Replace by
Workbooks("My_WB_2").Worksheets(CStr(Group.Value)).Range("B4").Value
In VBA / VB.NET you can assign Excel range values to an array for faster access / manipulation. Is there a way to efficiently assign other cell properties (e.g., top, left, width, height) to an array? I.e., I'd like to do something like:
Dim cellTops As Variant : cellTops = Application.ActiveSheet.UsedRange.Top
The code is part of a routine to programmatically check whether an image overlaps cells that are used in a workbook. My current method of iterating over the cells in the UsedRange is slow since it requires repeatedly polling for the top / left / width / height of the cells.
Update: I'm going to go ahead an accept Doug's answer as it does indeed work faster than naive iteration. In the end, I found that a non-naive iteration works faster for my purposes of detecting controls that overlap content-filled cells. The steps are basically:
(1) Find the interesting set of rows in the used range by looking at the tops and heights of the first cell in each row (my understanding is that all the cells in the row must have the same top and height, but not left and width)
(2) Iterate over the cells in the interesting rows and perform overlap detection using only the left and right positions of the cells.
The code for finding the interesting set of rows looks something like:
Dim feasible As Range = Nothing
For r% = 1 To used.Rows.Count
Dim rowTop% = used.Rows(r).Top
Dim rowBottom% = rowTop + used.Rows(r).Height
If rowTop <= objBottom AndAlso rowBottom >= objTop Then
If feasible Is Nothing Then
feasible = used.Rows(r)
Else
feasible = Application.Union(used.Rows(r), feasible)
End If
ElseIf rowTop > objBottom Then
Exit For
End If
Next r
Todd,
The best solution I could think of was to dump the tops into a range and then dump those range values into a variant array. As you said, the For Next (for 10,000 cells in my test) took a few seconds. So I created a function that returns the top of the cell that it's entered into.
The code below, is mainly a function that copies the usedrange of a sheet you pass to it and then enters the function described above into each cell of the usedrange of the copied sheet. It then transposes and dumps that range into a variant array.
It only takes a second or so for 10,000 cells. Don't know if it's useful, but it was an interesting question. If it is useful you could create a separate function for each property or pass the property you're looking for, or return four arrays(?)...
Option Explicit
Option Private Module
Sub test()
Dim tester As Variant
tester = GetCellProperties(ThisWorkbook.Worksheets(1))
MsgBox tester(LBound(tester), LBound(tester, 2))
MsgBox tester(UBound(tester), UBound(tester, 2))
End Sub
Function GetCellProperties(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
rngCopyOfUsedRange.Formula = "=CellTop()"
wsTemp.Calculate
GetCellProperties = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
Function CellTop()
CellTop = Application.Caller.Top
End Function
Todd,
In answer to your request for a non-custom-UDF I can only offer a solution close to what you started with. It takes about 10 times as long for 10,000 cells. The difference is that your back to looping through cells.
I'm pushing my personal envelope here, so maybe somebody will have a way to to it without a custom UDF.
Function GetCellProperties2(wsSourceWorksheet As Excel.Worksheet) As Variant
Dim wsTemp As Excel.Worksheet
Dim rngCopyOfUsedRange As Excel.Range
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
wsSourceWorksheet.Copy after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
Set wsTemp = ActiveSheet
Set rngCopyOfUsedRange = wsTemp.UsedRange
With rngCopyOfUsedRange
For i = 1 To .Cells.Count
.Cells(i).Value = wsSourceWorksheet.UsedRange.Cells(i).Top
Next i
End With
GetCellProperties2 = Application.WorksheetFunction.Transpose(rngCopyOfUsedRange)
Application.DisplayAlerts = False
wsTemp.Delete
Application.DisplayAlerts = True
Set wsTemp = Nothing
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Function
I would add to #Doug the following
Dim r as Range
Dim data() as Variant, i as Integer
Set r = Sheet1.Range("A2").Resize(100,1)
data = r.Value
' Alternatively initialize an empty array with
' ReDim data(1 to 100, 1 to 1)
For i=1 to 100
data(i,1) = ...
Next i
r.Value = data
which shows the basic process of getting a range into an array and back again.