I created a macro to plot graphs when the workbook is opened.
Sub create_graphs()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim LRowO As Long, LRowI As Long
Dim LColO As Long, LColI As Long
Dim Count As Integer
Dim LastChartRow As Integer
Set wsOutput = ThisWorkbook.Sheets("Summary")
With wsOutput
LRowI = .Range("A" & .Rows.Count).End(xlUp).Row
LColI = .Cells(1, .Columns.Count).End(xlToLeft).Column
LastChartRow = LRowI + 3
For Count = 2 To LRowI
.Shapes.AddChart2(201, xlColumnClustered).Select
ActiveChart.PlotBy = xlRows
ActiveChart.SetSourceData Source:=Range(.Cells(Count, 1), .Cells(Count,LColI))
ActiveChart.SeriesCollection(1).XValues = Range(.Cells(1, 2), .Cells(1,LColI))
ActiveChart.SetElement (msoElementDataLabelOutSideEnd)
ActiveChart.ChartTitle.Text = .Cells(Count, 1).Value
ActiveChart.Parent.Left = .Cells(LRowI + 5, 2).Left
ActiveChart.Parent.Top = .Cells(LastChartRow, 2).Top
LastChartRow = LastChartRow + 15
Next Count
End With
End Sub
Private Sub Workbook_Open()
Call create_graphs
End Sub
When I open the Excel workbook, it throws error message Object variable or With block variable not set and the graphs are not plotted. Checking from VB guide seems like it's variable issue. Please help to point out the mistake.
Is your sub on the workbook page in the visual editor? If not it needs to be on the same page or in a module vba will not call a sub from a different page.
Related
I'm trying to do a simple thing. The code is supposed to copy specific ranges from one workbook to another but when I run the following code copying doesn't occur - nothing happens. (copying happens in the last part of Sub). I suspect it might be a problem with worksheets/workbooks but I'm really new into VBA so it's hard to say for me...
Function getHeaderRange(searched As String, ws As Worksheet) As Range
Dim colNum
Dim cellLength
colNum = WorksheetFunction.Match(searched, ws.Range("5:5"))
cellLength = ws.Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
Set getHeaderRange = Range(ws.Cells(6, colNum), ws.Cells(6, colNum + cellLength - 1))
End Function
Function getDataRange(searched As String, hRange As Range) As Range
Dim column: column = WorksheetFunction.Match(searched, hRange) + hRange.column - 1
Set getDataRange = Range(Cells(6, column), Cells(6, column))
Debug.Print (hRange.Worksheet.Parent.Name & "Sheet: " & hRange.Worksheet.Name)
Set getDataRange = getDataRange.Offset(1, 0)
Set getDataRange = getDataRange.Resize(8)
End Function
Sub main()
Dim srcWs As Worksheet: Set srcWs = Workbooks("Period end open receivables, step 5").Sheets(1)
Dim trgWs As Worksheet: Set trgWs = ThisWorkbook.Sheets("Obiee")
Dim searched As String
Dim hSearched As String
searched = "Magazines, Merchants & Office"
Dim srcRange As Range: Set srcRange = getHeaderRange(searched, srcWs)
Dim trgRange As Range: Set trgRange = getHeaderRange(searched, trgWs)
Dim cocd() As Variant
Dim i As Integer
cocd = getHeaderRange("Magazines, Merchants & Office", trgWs)
For i = 1 To UBound(cocd, 2)
hSearched = cocd(1, i)
getDataRange(hSearched, srcRange).Copy
getDataRange(hSearched, trgRange).PasteSpecial xlPasteValues
Next i
End Sub
When I change last lines to:
For i = 1 To UBound(cocd, 2)
hSearched = cocd(1, i)
srcWs.Activate
getDataRange(hSearched, srcRange).Copy
trgWs.Activate
getDataRange(hSearched, trgRange).Select
ActiveSheet.Paste
Next i
It works just fine but I really would like to avoid this approach and find out what's wrong with the first one. Help really appreciated!
Edit: I'm including a to screenshots of workbooks (1. srcWb, 2. trgWb)
The file is huge and differentiated but in this cut they are the tables are the same.
Your ranges aren't fully qualified..
When they're not qualified, Excel will guess which worksheet the range in question resides on, usually using the currently active worksheet. That's why your workaround works as you change the active worksheet.
This line needs to be fully qualified:
cellLength = Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
So it'll become:
Function getHeaderRange(searched As String, ws As Worksheet) As Range
Dim colNum
Dim cellLength
colNum = WorksheetFunction.Match(searched, ws.Range("5:5"))
cellLength = ws.Range(ws.Cells(5, colNum), ws.Cells(5, colNum)).MergeArea.Count
Set getHeaderRange = ws.Range(ws.Cells(6, colNum), ws.Cells(6, colNum + cellLength - 1))
End Function
Also, this line is not qualified at all:
Set getDataRange = Range(Cells(6, column), Cells(6, column))
So it'll become:
Function getDataRange(searched As String, hRange As Range) As Range
Dim column: column = WorksheetFunction.Match(searched, hRange) + hRange.column - 1
Dim ws As Worksheet: Set ws = hRange.Worksheet
Set getDataRange = ws.Range(ws.Cells(6, column), ws.Cells(6, column))
Debug.Print (ws.Parent.Name & "Sheet: " & ws.Name)
Set getDataRange = getDataRange.Offset(1, 0)
Set getDataRange = getDataRange.Resize(8)
End Function
As per my comment below, to radically speed things up, I'd recommend removing these two lines from Main():
getDataRange(hSearched, srcRange).Copy
getDataRange(hSearched, trgRange).PasteSpecial xlPasteValues
and replacing them with:
getDataRange(hSearched, trgRange).Value = getDataRange(hSearched, srcRange).Value
Hi I'm trying to work through a table downloaded from a 3rd party that uses ticks (shapes) rather than text in the cells. The shapes have no textframe characters. I can't filter the ticks in excel so I want to replace then with text e.g. Yes. Here is my working code but get run time error 438 due to object errors I have tried the excel vba object model but can't get it to work. The VBE doesn't seem to have the Selection.ShapeRange
https://learn.microsoft.com/en-us/office/vba/api/excel.shape
https://learn.microsoft.com/en-us/office/vba/api/excel.shaperange
Here is my code
Sub ReplaceShapeswithYes()
' Inserts text where a shape exists
Dim ws As Worksheet
Dim NumRow As Integer
Dim iRow As Integer
Dim NumShapes As Long
Set ws = ActiveSheet
NumRow = ws.UsedRange.Rows.Count
For iRow = 2 To NumRow
Cells(iRow, 10).Select
'NumShapes = ActiveWindow.Selection.ShapeRange.Count ' tried both
NumShapes = Windows(1).Selection.ShapeRange.Count
If NumShapes > 0 Then
Cells(iRow, 10).Value = "Yes"
End If
Next iRow
End Sub
Many thanks
To get all shapes of a sheet, simply loop over the Shapes-collection of the sheet.
The text of a shape can be read with TextFrame.Characters.Text, but to be on the save side, you will need to check if a shape has really text (there are shapes that don't have any), see https://stackoverflow.com/a/16174772/7599798
To get the position withing a sheet, use the TopLeftCell-property.
The following code will copy the text of all shapes into the sheet and delete the shapes:
Sub shapeToText(Optional ws As Worksheet = Nothing)
If ws Is Nothing Then Set ws = ActiveSheet
Dim sh As Shape
For Each sh In ws.UsedRange.Shapes
If Not sh.TextFrame Is Nothing Then
If sh.TextFrame2.HasText Then
Dim s As String
s = sh.TextFrame.Characters.Text
sh.TopLeftCell = s
sh.Delete
End If
End If
Next
End Sub
This has done the trick
Sub ReplaceShapes()
'Replace all ticks with text
Dim NoShapes As Long
Dim iShape As Long
Dim ws As Worksheet
Dim r As Range
Dim Shp As Shape
Set ws = ActiveSheet
NoShapes = ws.Shapes.Count
For iShape = NoShapes To 1 Step -1:
Set Shp = ws.Shapes(iShape)
Set r = Shp.TopLeftCell
r.Value = "Yes"
Next iShape
End Sub
hope you can help me out here, because I really can't see the error.
I'm trying to create a Userform with a listbox, where the user can choose values from an array. The code for the array is below:
Dim arrayData As Range
Dim sh As Worksheet
Dim Row_Count As Integer
Dim i As Integer
Dim lastRow2 As Long
Set sh = ThisWorkbook.Sheets("Import")
lastRow2 = sh.Columns(45).Find("*", , , , xlByRows, xlPrevious).Row
Set arrayData = sh.Range("AS2:AS" & lastRow2)
arArray = sh.Range("AS2:AS" & lastRow2)
Row_Count = arrayData.Rows.Count
For i = 1 To Row_Count
arArray(i, 45) = Cells(i, 45).Value
Next i
This works perfectly. Now I'm initializing the Userform:
Public Sub UserForm_Initialize()
Auswertung.Lst_Tabellen.List.Clear
Auswertung.Lst_Tabellen.List = arArray
End Sub
But everytime I'm trying to call the userform "Auswertung", I get the error "Runtime Error 424: Object Required". Can you guys see the issue?
Public Sub Call_Userform()
Auswertung.Show
End Sub
The Debugger marks the line "Auswertung.Show", when I run the code.
As I mentioned, you need to populate the array inside UserForm_Initialize()
Here is an example. To test this, relace your UserForm_Initialize with the below code.
Option Explicit
Private Sub UserForm_Initialize()
Dim ws As Worksheet
Dim lRow As Long
Dim arRange As Range
Dim arData As Variant
'~~> Set your worksheet here
Set ws = ThisWorkbook.Sheets("Import")
With ws
'~~> Find last row in column AS
lRow = .Range("AS" & .Rows.Count).End(xlUp).Row
'~~> Identify your range
Set arRange = .Range("AS2:AS" & lRow)
'~~> Get the data into an array. This will be a 2D array
arData = arRange.Value2
End With
With Lst_Tabellen
.Clear
'~~> Transpose to get 0-based array
.List = Application.Transpose(arData)
End With
End Sub
as you wrote, arArray is Variant
arArray = sh.Range("AS2:AS" & lastRow2) --> arArray is a one dimensional array
...
arArray(i, 45) = Cells(i, 45).Value --> arArray becomes a 2 dimensional array
...
Auswertung.Lst_Tabellen.List = arArray --> result unknown
Pls check the above, is it what you really want?
I have 2 columns on a sheet "list", one column that lists all business entities, the other lists all org units. The functionality of the code below works perfectly but returns an error because it exceeds the sheet row limit.
The data is pasted onto a sheet "cc_act" is there a way to at point of error create a new sheet called "cc_act1"...."cc_act2" until the script is complete?
Declare Function HypMenuVRefresh Lib "HsAddin" () As Long
Sub cc()
Application.ScreenUpdating = False
Dim list As Worksheet: Set list = ThisWorkbook.Worksheets("list")
Dim p As Worksheet: Set p = ThisWorkbook.Worksheets("p")
Dim calc As Worksheet: Set calc = ThisWorkbook.Worksheets("calc")
Dim cc As Worksheet: Set cc = ThisWorkbook.Worksheets("cc_act")
Dim cc_lr As Long
Dim calc_lr As Long: calc_lr = calc.Cells(Rows.Count, "A").End(xlUp).Row
Dim calc_lc As Long: calc_lc = calc.Cells(1,
calc.Columns.Count).End(xlToLeft).Column
Dim calc_rg As Range
Dim ctry_rg As Range
Dim i As Integer
Dim x As Integer
list.Activate
For x = 2 To Range("B" & Rows.Count).End(xlUp).Row
If list.Range("B" & x).Value <> "" Then
p.Cells(17, 3) = list.Range("B" & x).Value
End If
For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
If list.Range("A" & i).Value <> "" Then
p.Cells(17, 4) = list.Range("A" & i).Value
p.Calculate
End If
p.Activate
Call HypMenuVRefresh
p.Calculate
'''changes country on calc table
calc.Cells(2, 2) = p.Cells(17, 4)
calc.Cells(2, 3) = p.Cells(17, 3)
calc.Calculate
'''copy the calc range and past under last column
With calc
Set calc_rg = calc.Range("A2:F2" & calc_lr)
End With
With cc
cc_lr = cc.Cells(Rows.Count, "A").End(xlUp).Row + 1
calc_rg.Copy
cc.Cells(cc_lr, "A").PasteSpecial xlPasteValues
End With
Next i
Next x
Application.ScreenUpdating = True
End Sub
I suppose there are a few ways to handle something like this. See the code sample below, and adapt it to your specific needs.
Sub LongColumnToAFewColumns()
Dim wsF As Worksheet, WST As Worksheet
Dim rf As Range, rT As Range
Dim R As Long, j As Integer
' initialize
Set wsF = ActiveSheet
Set WST = Sheets.Add
WST.Name = "Results"
j = 1
For R = 1 To wsF.Cells(Rows.Count, 1).End(xlUp).Row Step 65536
wsF.Cells(R, 1).Resize(65536).Copy
WST.Cells(j, 1).PasteSpecial xlPasteValues
WST.Cells(j, 1).PasteSpecial xlPasteValues
j = j + 1
Next R
End Sub
As an aside, you may want to consider using MS Access for this kind of thing. Or, better yet, Python or even R. Good luck with your project.
trying to work the VBA autofill function (end of code block) but I am running into an error everytime I try the execute the code. I get "Autofill method of Range class failed". Can someone help me out here? Searched google but nothing works. Probably overlooking something small. Thanks in advance for the help.
Sub UpdateLAB() '---> still need to work on this
'author: css
Dim SalesBook As Workbook
Dim ws2 As Worksheet
Dim wspath As String
Dim n As Integer
Dim FirstRow As Long
Dim LastRow As Long
Dim LastRow2 As Long
Dim sourceCol As Integer
Dim RefCellValue2 As String
Dim ps As String
Dim Platts As Workbook
Application.Calculation = xlCalculationAutomatic
Set SalesBook = Workbooks("ALamb.xlsm")
Set ws2 = SalesBook.Worksheets("US LAB Price")
wspath = "C:\Users\scullycs\Desktop\P&O\Platts Data\Platts 2016.xlsm"
FirstRow = ws2.Range("B4").Row
LastRow = ws2.Range("B4").End(xlDown).Row + 1
LastRow2 = ws2.Range("c4").End(xlDown).Row
sourceCol = 2 'refers to the column your data is in
For n = FirstRow To LastRow
RefCellValue2 = Cells(n, sourceCol).Value
If IsEmpty(RefCellValue2) Or RefCellValue2 = "" Then
Cells(n, sourceCol).Offset(0, -1).Copy
SalesBook.Worksheets("Control Page").Range("C8").PasteSpecial (xlPasteValues)
Else
End If
Next n
ps = SalesBook.Worksheets("Control Page").Range("C9").Text
Set Platts = Workbooks.Open(wspath)
Platts.Worksheets(ps).Activate
Range("A13").End(xlDown).Select
Selection.Offset(0, 11).Select
If Selection.Value = "" Then
MsgBox ("Platts data does not exist")
Platts.Close
Else
Selection.Copy
Set SalesBook = Workbooks("ALamb.xlsm")
SalesBook.Worksheets("US LAB Price").Range("b1").End(xlDown).Offset(1, 0).PasteSpecial (xlPasteValues)
'this is where I get the error
SalesBook.Worksheets("US LAB Price").Range("c4").AutoFill Destination:=Range("C4:C" & LastRow2), Type:=xlFillDefault
Platts.Close
End If
End Sub
Most probably your ranges are not overlapping OR range is too big. In case you want to refer, link.
Check the value of LastRow2.
Make sure the fill range is from same sheet to make them over lapping. To do so break your statement into simple steps. Later you can combine.
Will suggest to break down the statement into
Set SourceRange = SalesBook.Worksheets("US LAB Price").Range("C4:C4")
Set fillRange = SalesBook.Worksheets("US LAB Price").Range("C4:C" & LastRow2)
SourceRange.AutoFill Destination:=fillRange, Type:=xlFillDefault