I'm trying to make a loop that will create a chart for each row in my Excel sheet. I can't use a sparkline.
Sub chartcreation()
'
chartcreation Macro
'
Sub Main()
x$ = 2
Do While Cells(x$, 2) <> ""
Range("A1:Tx$").Select
Range("Tx$").Activate
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SetSourceData Source:=Range("MAY!$A$1:$T$1",MAY!A$(x$)$T$x$")
ActiveSheet.Shapes("Chart 3").IncrementLeft 380.6249606299
ActiveSheet.Shapes("Chart 3").IncrementTop -270
x = x + 1
End Sub
I've rewritten your code below with what I believe you are looking for. This will go through every row with a value in column B, create chart, and place the upper left corner of the chart in column U for that row.
Option Explicit
Sub Main()
Dim strChrt As String
Dim ws As Worksheet
Dim x As Integer
Dim lastRow As Integer
Set ws = ActiveSheet
lastRow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For x = 2 To lastRow
ws.Range(ws.Cells(x, "A"), ws.Cells(x, "T")).Select
ws.Shapes.AddChart2(227, xlLine).Select
strChrt = Trim(Replace(ActiveChart.Name, ActiveSheet.Name, ""))
ActiveSheet.Shapes(strChrt).Left = ws.Cells(x, "U").Left
ActiveSheet.Shapes(strChrt).Top = ws.Cells(x, "U").Top
Next x
End Sub
Related
I have a macro that is building a bubble chart and for each row in the dynamic range it is creating a new series in the bubble chart. I tested the last row calculation was finding the actual last row both manually on the worksheet and with a quick macro to find the last row and display in a message box. So the macro for building the bubble chart is finding the last row correctly. The problem is that the macro is adding in blank series anyway beyond the last row. The macro is adding 10 generic series after the last row.
Macro below:
Sub bubble()
'
' bubble Macro for bubble chart
'
Dim Lastrow As Long, ws As Worksheet, wsRD As Worksheet, wsChart As Worksheet
Dim cht As ChartObject, currRow As Integer
Dim ch As Shape, SeriesNum As Integer
On Error GoTo ExitSub
For Each ws In ActiveWorkbook.Sheets
If Left(ws.Name, 12) = "Raw Data SEA" Then
Set wsRD = ws
End If
If Left(ws.Name, 10) = "SEA bubble" Then
Set wsChart = ws
End If
Next ws
Lastrow = wsRD.Cells(Rows.Count, 1).End(xlUp).Row
Set ch = wsChart.Shapes(1)
ch.Name = "SEACht"
SeriesNum = 1
For currRow = 2 To Lastrow
ch.Chart.SeriesCollection.NewSeries
ch.Chart.FullSeriesCollection(SeriesNum).Name = wsRD.Cells(currRow, 1)
ch.Chart.FullSeriesCollection(SeriesNum).XValues = wsRD.Cells(currRow, 2)
ch.Chart.FullSeriesCollection(SeriesNum).Values = wsRD.Cells(currRow, 4)
ch.Chart.FullSeriesCollection(SeriesNum).BubbleSizes = wsRD.Cells(currRow, 3)
SeriesNum = SeriesNum + 1
Next currRow
'Format Legend
ch.Chart.PlotArea.Select
ch.Chart.SetElement (msoElementLegendBottom)
ActiveWorkbook.Save
'Format X and Y axes
ch.Chart.Axes(xlCategory).Select
ch.Chart.Axes(xlCategory).MinimumScale = 0
ch.Chart.ChartArea.Select
ch.Chart.Axes(xlValue).Select
ch.Chart.Axes(xlValue).MinimumScale = 0
Application.CommandBars("Format Object").Visible = False
ActiveWorkbook.Save
' Format datalabels
ch.Chart.ApplyDataLabels
ch.Chart.FullSeriesCollection(1).DataLabels.Select
ch.Chart.FullSeriesCollection(1).HasLeaderLines = False
Application.CommandBars("Format Object").Visible = False
ActiveWorkbook.Save
' Add charttitle
'
ch.Chart.SetElement (msoElementChartTitleAboveChart)
ch.Chart.Paste
ch.Chart.ChartTitle.Text = _
"Properties operating exp - RSF and Building Age Factors"
ActiveWorkbook.Save
ExitSub:
End Sub
Thanks in advance for any help.
Checked that the last row calc was actually finding the last row to make sure that was not the issue. Tried recording the process again to see if I missed anything. I didn't see anything that was obvious to change.
Too long for a comment and maybe not the source of your problem, but NewSeries returns the added series, so you can do this and skip the SeriesNum counter:
Dim rw as Range
For currRow = 2 To Lastrow
Set rw = wsRD.Rows(currRow)
With ch.Chart.SeriesCollection.NewSeries
.Name = rw.Cells(1)
.XValues = rw.Cells(2)
.Values = rw.Cells(4)
.BubbleSizes = rw.Cells(3)
End With
Next currRow
I wasn't able to find any vba zoom except for auto-changing based on resolution, but is it possible to autofit custom zoom level based on most furthest out column that has text?
Sub Workbook_Open()
ActiveWindow.Zoom = 100 'also you can change to other size
End Sub
Bonus Code:
To reset the scroll bar to far left, so it's looking at Column A/Row1, this code works :) I have it on a "reset" userbutton.
'Scroll to a specific row and column
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
Thank you in advance.
Try this code:
Function FindFurthestColumn(S As Worksheet) As Integer
Dim CellsWithContent As Long
CellsWithContent = WorksheetFunction.CountA(S.Cells)
If CellsWithContent = 0 Then
FindFurthestColumn = 1
Exit Function
End If
Dim CellsCount As Long
Dim j As Integer
Do
j = j + 1
CellsCount = CellsCount + WorksheetFunction.CountA(S.Columns(j))
Loop Until CellsCount = CellsWithContent
FindFurthestColumn = j
End Function
Function CellIsVisible(cell As Range) As Boolean
CellIsVisible = Not Intersect(ActiveWindow.VisibleRange, cell) Is Nothing
End Function
Sub ZoomVisibleCells()
Application.ScreenUpdating = False
Dim LastColumn As Integer
LastColumn = FindFurthestColumn(ActiveSheet)
Dim SplitCell As Range
If ActiveWindow.Split = True Then
Set SplitCell = Cells(ActiveWindow.SplitRow + 1, ActiveWindow.SplitColumn + 1)
ActiveWindow.FreezePanes = False
End If
Dim Zoom As Integer
For Zoom = 400 To 10 Step -1
ActiveWindow.ScrollRow = 1
ActiveWindow.ScrollColumn = 1
ActiveWindow.Zoom = Zoom
If CellIsVisible(ActiveSheet.Cells(1, LastColumn + 1)) Then
Exit For
End If
Next Zoom
If Not SplitCell Is Nothing Then
SplitCell.Activate
ActiveWindow.FreezePanes = True
End If
Application.ScreenUpdating = True
End Sub
Credit for the CellIsVisible function:
https://stackoverflow.com/a/11943260/14370454
AUTO ZOOM RESPONSIVE VIEW EXCEL VBA CODE
In a sheet type any character on cell A1 and your last column view then type a character on first row with last column. That's it, see a magic of responsive view Excel sheet/s.
Note: copy this code and paste it to Thisworkbook module.
Thank you all.
Private Sub Workbook_WindowResize(ByVal Wn As Window)
Dim LastCol As Long
Dim rng As Range
Dim x As Integer
Dim y As Integer
With ActiveSheet
Set rng = .Rows(1).Find(What:="*", LookIn:=xlFormulas, SearchDirection:=xlPrevious)
End With
If Not rng Is Nothing Then
LastCol = rng.Column
Else
LastCol = 1
End If
x = 1 ' For First Column
y = LastCol ' For Last
Columns(Chr(64 + x) & ":" & Chr(64 + y)).Select
ActiveWindow.Zoom = True
ActiveSheet.Range("E1").Select
End Sub
This is really simple but I'm new to VBA.
I want to format cells in column J and K (haven't gotten to K yet) with a grey fill and border around if cells in column B is not empty. I want to do this in every worksheet in the workbook.
Sub forEachWs()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
Call Format_ForecastingTemplate(ws)
Next
End Sub
Sub Format_ForecastingTemplate(ws As Worksheet)
Dim cell As Range
Dim N As Long
Dim i As Long
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
If cell <> "" Then
With ActiveSheet.Range(Cells("J"), cell.Row)
.ThemeColor = xlThemeColorDark1
.BorderAround LineStyle:=xlContinuous
End With
End If
Next
End Sub
The line that is giving me an error is If cell <> "" Then. I think it's because I'm not referencing the cell variable in column B?
Error is: Object variable or With block variable not set
Like this:
I changed it to a single macro and made changes to your original code
Sub Format_ForecastingTemplate()
Dim cell As Range
Dim N As Long
Dim i As Long
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
N = Cells(Rows.Count, "B").End(xlUp).Row
For i = 1 To N
'Looks at B to check if empty
If ws.Cells(i, 2).Value <> "" Then
'changes cells J to color and border
ws.Cells(i, 10).Borders.LineStyle = xlContinuous
ws.Cells(i, 10).Interior.ThemeColor = xlThemeColorDark1
ws.Cells(i, 10).Interior.TintAndShade = -0.25
End If
Next i
Next ws
End Sub
You can either change the column number or add new lines for column K
Hope this helps and please be kind and leave feedback. :)
I have some history working with VBA, but can't seem to find the solution to this problem. I found an iteration process to select a cell, do a process, and then select the next cell and do the process again, until NULL. I am having a problem outputting each of the processes solutions into the next column. Here is what I have:
Sub Name ()
Dim X As Integer
Dim MyString as String
Application.ScreenUpdating = False
NumRows = Range("D2", Range("D2").End(xlDown)).Rows.Count
Range("D2").Select
For X = 1 To NumRows
MyString = ActiveCell.Value
MyString = Right(MyString, Len(MyString)-6)
Range("I2 to I#").Value = MyString
ActiveCell.Offset(1,0).Select
Next X
End Sub
Range("I2 to I#").Value = MyString is the line that I need help with. I need it to increment to I3, I4, I5, etc. until it reaches NumRows count.
When working with Cells the best way to loop through them is For Each Cell in Range so taking this and as comments told you to avoid selecting, this should help you:
Option Explicit
Sub Name()
Dim C As Range, MyRange As Range
Dim LastRow As Long
Application.ScreenUpdating = False
With ThisWorkbook.Sheets("MySheet") 'Change MySheet for your working sheet name
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row 'last row on column D
Set MyRange = .Range("D2:D" & LastRow) 'declare your working range
For Each C In MyRange
If Not C = vbNullString Then .Cells(C.Row, "I") = Right(C, Len(C) - 6)
Next C
End With
Application.ScreenUpdating = True
End Sub
Another solution is Do Until. You could use this method if you dont have empty cells in the middle of your data.
Option Explicit
Sub Test()
Dim StartingPoint As Long
StartingPoint = 2 'Set the line to begin
With ThisWorkbook.Worksheets("Sheet1") 'Set the worksheet
Do Until .Cells(StartingPoint, "D").Value = "" 'Repeat the process until you find empty cell
.Cells(StartingPoint, "I").Value = Right(.Cells(StartingPoint, "D").Value, Len(.Cells(StartingPoint, "D").Value) - 6)
StartingPoint = StartingPoint + 1
Loop
End With
End Sub
I am creating a userform containing 2 textboxes, 4 different check boxes, 4 radial buttons and 2 command buttons, as seen below:
I want to change the row and column widths in the active sheet, or all the worksheets in a workbook, based on the selections in the form.
Frames
TextBox1 (Column Width), TextBox2 (Row Height)
To type the row height and column width.
Optionbutton1 (Column B onwards) , OptionButton2 (Column C onwards)
To select from which Column (B or C) you want to change the column width.
Optionbutton3 (Selected Sheet), OptionButton4 (All sheets)
To select on which sheet you want to change the row height and column width ( On Active sheet or On All the sheets).
CheckBox1 (Cover) , CheckBox2 (Trans_Letter), CheckBox3 (Abbreviations) CheckBox3 (Sheet ending with _Index)
One check box each for 4 of the sheets in my workbook. There are ~50 sheets in my workbook, these check boxes are for selecting which sheets to exclude while changing the column width and row height, when changing all of the sheets.
Please find below the code which I have put in the userform.
I am getting error on this line:
If IsError(WorksheetFunction.Match(ThisWorkbook.Worksheets(sheetNumber).Name, sheetsToExcludeArray, 0)) Then
Error Message: Run Time error '1004' Unable to get the Match property
of the worksheet function
Private Sub CommandButton1_Click()
Dim startColumn As Long
Dim formatAllSheets As Boolean
Dim sheetsToExcludeList As String
Dim sheetNumber As Long
startColumn = 3
If Me.OptionButton1.Value Then startColumn = 2
formatAllSheets = True
If Me.OptionButton3.Value Then formatAllSheets = False
If Me.CheckBox1.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Cover"
If Me.CheckBox2.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Trans_Letter"
If Me.CheckBox3.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Abbreviations"
If Me.CheckBox4.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Index"
sheetsToExcludeList = Mid(sheetsToExcludeList, 2)
Dim lastRow As Long
Dim lastColumn As Long
Dim itemInArray As Long
Dim rangeToFormat As Range
Dim sheetsToExcludeArray As Variant
If startColumn < 2 Or startColumn > 3 Then startColumn = 2
sheetsToExcludeArray = Split(sheetsToExcludeList, ",")
If formatAllSheets Then
For sheetNumber = 1 To ThisWorkbook.Worksheets.Count
If LBound(sheetsToExcludeArray) <= UBound(sheetsToExcludeArray) Then
If IsError(WorksheetFunction.Match(ThisWorkbook.Worksheets(sheetNumber).Name, sheetsToExcludeArray, 0)) Then
With ThisWorkbook.Worksheets(sheetNumber)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rangeToFormat = .Range(.Cells(1, startColumn), .Cells(lastRow, lastColumn))
rangeToFormat.Cells.RowHeight = me.textbox1.value
rangeToFormat.Cells.ColumnWidth = me.textbox2.value
End With
End If
Else
With ThisWorkbook.Worksheets(sheetNumber)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rangeToFormat = .Range(.Cells(1, startColumn), .Cells(lastRow, lastColumn))
rangeToFormat.Cells.RowHeight = me.textbox1.value
rangeToFormat.Cells.ColumnWidth = me.texbox2.value
End With
End If
Next sheetNumber
Else
With ThisWorkbook.Worksheets(sheetNumber)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
lastColumn = .Cells(1, .Columns.Count).End(xlToLeft).Column
Set rangeToFormat = .Range(.Cells(1, startColumn), .Cells(lastRow, lastColumn))
rangeToFormat.Cells.RowHeight = me.textbox1.value
rangeToFormat.Cells.ColumnWidth = me.textbox2.value
End With
End If
End Sub
Note, this answer uses an adaptation of the sub resizerowscols, which I wrote to answer your more recent question: Change column width and row height of hidden columns and rows (remaining hidden): Excel VBA
Main Click Sub
This (untested) sub takes the values from the form, then loops through the sheets (or just uses active sheet) and calls the other sub to do the resizing.
Sub CommandButton1_Click()
' Frame 1 values
Dim colwidth As Double
colwidth = Me.TextBox1.Value
Dim rowheight As Double
rowheight = Me.TextBox2.Value
' Frame 2 values
Dim selectedCol As String
If Me.OptionButton1.Value = True Then
selectedCol = "B"
Else
selectedCol = "C"
End If
' Frame 3 values
Dim doAllSheets As Boolean
doAllSheets = Me.OptionButton4.Value
'Frame 4 values
Dim sheetsToExcludeList As String
If Me.CheckBox1.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Cover"
If Me.CheckBox2.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Trans_Letter"
If Me.CheckBox3.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Abbreviations"
If Me.CheckBox4.Value Then sheetsToExcludeList = sheetsToExcludeList & ",Index"
' Resizing
Dim shtrng As Range
Dim sht As Worksheet
If doAllSheets Then
' Loop through sheets
For Each sht In ThisWorkbook.Sheets
' Check sheet name isn't on exclude list
If InStr(sheetsToExcludeList, "," & sht.Name) = 0 Then
' Set range equal to intersection of used range and columns "selected column" onwards
Set shtrng = Intersect(sht.UsedRange, sht.Range(sht.Cells(1, selectedCol), sht.Cells(1, sht.Columns.Count)).EntireColumn)
' Resize columns / rows
resizerowscols rng:=shtrng, w:=colwidth, h:=rowheight
End If
Next sht
Else
' Just active sheet
Set sht = ThisWorkbook.ActiveSheet
Set shtrng = Intersect(sht.UsedRange, sht.Range(sht.Cells(1, selectedCol), sht.Cells(1, sht.Columns.Count)).EntireColumn)
resizerowscols rng:=shtrng, w:=colwidth, h:=rowheight
End If
End Sub
This is the adapted Sub from your other question, but now it takes the range, height and width as arguments. It unhides all rows/columns, resizes them, and re-hides all those which already were.
Sub resizerowscols(rng As Range, w As Double, h As Double)
' Resizes all rows and columns, including those which are hidden.
' At the end, hidden rows and columns remain hidden.
If rng Is Nothing Then Exit Sub
Dim n As Long
Dim hiddencols() As Long
Dim hiddenrows() As Long
Application.ScreenUpdating = False
' Get hidden rows/cols
ReDim hiddencols(rng.Columns.Count)
ReDim hiddenrows(rng.Rows.Count)
For n = 0 To UBound(hiddencols)
hiddencols(n) = rng.Columns(n + 1).Hidden
Next n
For n = 0 To UBound(hiddenrows)
hiddenrows(n) = rng.Rows(n + 1).Hidden
Next n
' Unhide all
rng.EntireColumn.Hidden = False
rng.EntireRow.Hidden = False
' resize all
rng.ColumnWidth = w
rng.rowheight = h
' Re-hide rows/cols
For n = 0 To UBound(hiddencols)
rng.Columns(n + 1).Hidden = hiddencols(n)
Next n
For n = 0 To UBound(hiddenrows)
rng.Rows(n + 1).Hidden = hiddenrows(n)
Next n
Application.ScreenUpdating = True
End Sub