My overall project is to have a sheet that acts as an array/repository for values to be referenced, and to provide this as part of a macro for others to use. I have other code that references this array, and in the setup macro I have a check if this sheet already exists:
Sub Detailed_Report_SS_Setup()
Application.DisplayAlerts = False
Dim ws As Worksheet
On Error Resume Next
Set ws = Sheets("Array")
On Error GoTo 0
If Not ws Is Nothing Then
Else
Sheets.Add().Name = "Array"
Populate_Array_Sheet
End If
Application.DisplayAlerts = True
End Sub
In trying to make the Populate_Array_Sheet, I attempted to manipulate some existing code I used to name sheets in a workbook. My issue is that excel is looping through my array and adding each value to every row of the column, overwriting values as it goes through the array.
I believe my issue is the bounds (i use lower and upper), though I don't know enough about this to figure out how to correct. Here is my example of the problematic code:
Sub Populate_Array_Sheet()
Dim i As Long
Dim Arf As Variant
Arf = Array("n1", "n2", "n3", ..., "n36")
For i = LBound(Arf) To UBound(Arf)
Sheets("Array").Range("A1:A36") = Arf(i)
Next i
End Sub
I'm trying to get each individual value (n1 through n36) onto its own row in the column.
you are using Range("A1:A36") you are applying the value to entire range Try this
Sub Populate_Array_Sheet()
Dim i As Long
Dim Arf As Variant
Arf = Array("n1", "n2", "n3",....., "n36")
Sheets("Array").Range("A1").Activate
For i = LBound(Arf) To UBound(Arf)
ActiveCell.Value = Arf(i)
ActiveCell.Offset(1, 0).Activate
Next i
End Sub
Related
I am trying to write a vba script that will allow me to vlookup values from Sheet(3) to different Sheet(i) - and paste it on range"R2" on the Sheet(i) - I also want it to go to the end of the values in Column M on Sheet(i) [if this is possible]. I basically want to run through all the different "i" sheets on the workbook. Sheet (3) has all the data that needs to be copied on all the other "i" sheets.
I keep getting an error with my code below.
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
If IsError(Application.WorksheetFunction.VLookup(wka.Range("M2"), wkb.Range("E:T"), 14, 0)) Then
wka.Range("R2").Value = ""
Else
wka.Range("R2").Value = Application.WorksheetFunction.VLookup(wka.Range("M2"), wks.Range("E:T"), 14, 0)
End If
Next i
End Sub
IsError does not work with Application.WorksheetFunction.VLookup or WorksheetFunction.VLookup, only with Application.VLookup.
It is faster and easier to return Application.Match once to a variant type variable and then test that for use.
dim am as variant
'are you sure you want wkb and not wks here?
am = Application.match(wka.Range("M2"), wkb.Range("E:E"), 0)
If IsError(am) Then
wka.Range("R2") = vbnullstring
Else
'are you sure you want wks and not wkb here?
wka.Range("R2") = wks.cells(am, "R").value
End If
Note the apparent misuse of wkb and wks in two places. I don't see the point of looking up a value in one worksheet, testing that return then using the results of the test to lookup the same value in another worksheet.
You can use the following code:
Sub CopyTableau1Data()
Dim wka As Worksheet
Dim wkb As Worksheet, i As Integer
ShtCount = ActiveWorkbook.Sheets.Count
For i = 9 To ShtCount
With ThisWorkbook
Set wka = .Sheets(i)
Set wkb = .Sheets(3)
End With
Worksheets(i).Activate
wka.Range("R2") = aVL(i)
Next i
End Sub
Function aVL(ByVal wsno As Integer) As String
On Error GoTo errhandler:
aVL =
Application.WorksheetFunction.VLookup(ActiveWorkbook.Worksheets(wsno).Range("M2"),
ActiveWorkbook.Worksheets(3).Range("E:T"), 14, False)
errhandler:
aVL = ""
End Function
When you try to check an error by isError, program flow can immediately return from the sub depending on the error. You could use on error in your sub to prevent that but this would only handle the first error. By delegating the error handling to a function you can repeatedly handle errors in your loop.
I assumed you wanted to use wkb.Range("E:T") instead of wks.Range("E:T").
The code below copies data from a specific column and transfers it to another one. For example, if in column A I have data from row 1 to 10 and press the button, then the values from row 1 to 10 will be transferred to i.e. column D. Afterwards, If I change the values in row 5, 7 and 9 in column A and press the button, only the values from row 5, 7 and 9 will be transferred to column D. The reason why the code is like that is because the worksheet has many rows filled with values and I want to be transferred (copy) only the values that have been modified. Otherwise, it will take quite some time.
The code works, but sometimes I get the error The commnand cannot be used on multiple selections. I tried to have a look on the internet to fix it but I couldn't come up with any solutions. Any help will be appreciated!
Note: A user from this community helped me to write the code below a time ago, but I cannot find the link anymore for that.
This code is pasted in the worksheet that I am using:
Option Explicit
Private Sub Worksheet_Change(ByVal target As Range)
Dim creation As Worksheet
Set creation = ActiveSheet
Dim copydata As Range
Set copydata = Application.Intersect(target, creation.Range("A2:A5000", "A" & creation.Rows.Count))
If (Not copydata Is Nothing) Then
If (CopyDataRange Is Nothing) Then
Set CopyDataRange = copydata
Else
Set CopyDataRange = Application.Union(CopyDataRange, copydata)
End If
End If
End Sub
And this code is pasted in a module:
Option Explicit
Public CopyDataRange As Range
Public Sub CommandButton1_Click()
Application.ScreenUpdating = False
If (Not CopyDataRange Is Nothing) Then
CopyDataRange.Copy
CopyDataRange.Offset(0, 3).PasteSpecial Paste:=xlPasteValues ' this where I get the error
Set CopyDataRange = Nothing
End If
Application.ScreenUpdating = True
End Sub
PasteSpecial doesn't work on multiple ranges. You can loop over all parts of the range using the Areas property:
if Not CopyDataRange Is Nothing then
Dim r As Range
For Each r In CopyDataRange.Areas
r.Copy
r.Offset(0, 3).PasteSpecial Paste:=xlPasteValues
Next
set CopyDataRange = nothing
end if
This will work even if you don't have a multiple range, in that case it contains only one Area (Areas.Count = 1)
I've been creating a VBA code to help me with a worksheet I use but I'm stuck at a certain point.
The code looks at the table on the current worksheet, adds a new column to the end of the table and then I get it to copy the first column in the worksheet (as this has the formats and some calculated cells). This is where my coding finishes. Ideally I would then like it to take the copied cells and paste them into the new end column of the table.
This is what I have so far:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Set oSh = ActiveSheet
With oSh.ListObjects("Labour")
.ListColumns.Add
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
End With
Application.ScreenUpdating = True
End Sub
(Labour being the name of the current table).
If I can get this to work fantastic but then I think I will encounter another issue. The table is on a template worksheet and contained on this I have a command button to create a copy of the template (for different tasks). This would then change the name of the table (Labour1 then Labour2 etc as new worksheets are created). How would I get the code to work on new worksheets as the code I have at the minute would simply want to link back to the original table (Labour).
You don't need actually copy values from the first column to the newly created, just use formula. I have modified your code:
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim str As String
Set oSh = ActiveSheet
Set oList = oSh.ListObjects("Labour")
With oList
.ListColumns.Add
str = .ListColumns(1).Name
.ListColumns(.ListColumns.Count).DataBodyRange.FormulaR1C1 = "=[#[" & str & "]]"
End With
End Sub
If you need actual values, not formulas, you may copy and paste special the last column. Before end with add:
With .ListColumns(.ListColumns.Count).DataBodyRange
.Copy
.PasteSpecial xlPasteValues
End With
This is answer to your first question. Unfortunately, I am not able to understand the second. Besides, I think you should ask it separately.
OK I have tweaked your code #MarcinSzaleniec and it appears to be working.
Sub AddNewColumn()
Application.ScreenUpdating = False
Dim oSh As Worksheet
Dim oList As ListObject
Dim str As String
Set oSh = ActiveSheet
Set oList = oSh.ListObjects("Labour")
With oList
.ListColumns.Add
str = .ListColumns(1).Name
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
.ListColumns(.ListColumns.Count).DataBodyRange.PasteSpecial xlPasteAll
Application.ScreenUpdating = True
End With
End Sub
The reason I need:
Range("Labour[[#All],[Column16]]").Select
Selection.Copy
Is due to it being a column hidden out the way and has the blank bits blank and the formula bits as formulas.
Many thanks for everybody's help. Now to ask the second part of my question on here.
I've recently discovered VBA code to filter slicers based off of variable names. It is a great tool for filtering what you want to see
The next step in my code is to potentially REMOVE visible data from my pivot table/chart (automatically).
Lets say I already have a variable "Remove_ITEM" that needs to be removed from the data shown. Remove_item is inside slicer ("slicer_Order").
The data is also inside a data model.
The code below is to ONLY show REmove_Item:
ActiveWorkbook.SlicerCaches("Slicer_Order").'VisibleSlicerItemsList = ("[Actuals_Table].[Order].&["& Remove_item &"]")
Now i want to do the opposite
I hope I understood what you are trying to achieve in your post.
Try the code below and let me know if it works as you intended:
Option Explicit
Sub SlicersTst()
Dim WB As Workbook
Dim OrderSlcrCache As SlicerCache
Dim OrderSlcItem As SlicerItem
Dim RemoveItem As Variant
Set WB = ThisWorkbook
Set OrderSlcrCache = WB.SlicerCaches("Slicer_Order") '<-- set Slicer Cache to "Order" slicer
OrderSlcrCache.ClearManualFilter '<-- clear manual filters
RemoveItem = "c" '<-- set value for test
' loop through all slicer items in slicer "Order"
For Each OrderSlcItem In OrderSlcrCache.SlicerItems
If OrderSlcItem.Name = RemoveItem Then OrderSlcItem.Selected = False
Next OrderSlcItem
End Sub
Please keep in mind this is specifically for data model usage with a connection.
Sub Variables()
Part_Number = Worksheets("Solumina_Data_Page").Cells(Row, "B").Value
End Sub
Sub Sort_Part_Number()
Application.ScreenUpdating = False
Page1 = ActiveSheet.Name
Call Variables
Sheets("Dashboard").Activate
ActiveWorkbook.SlicerCaches("Slicer_Material").VisibleSlicerItemsList = "[Part List].[Material].&[" & Part_Number & "]"
' "[Part List].[Material].&[77C726210G1]" <<What we want to see
Sheets(Page1).Activate
Application.ScreenUpdating = True
End Sub
Heres a similar example using the array
Sub Use_ARRAY()
Dim ARR() As String
ReDim ARR(1 To 2)
Call Array_Actuals_Data 'get data
Call Array_Outliers_removed 'sort data
ARR(1) = "[Actuals_Table].[Order].&[000010840921]"
ARR(2) = "[Actuals_Table].[Order].&[000010949159]"
ActiveWorkbook.SlicerCaches("Slicer_order").VisibleSlicerItemsList = ARR()
End Sub
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.