I have a question regarding VBA.
I am trying to apply the below code to all the sheets in a workbook.
The workbook contains numerous worksheets but have all the datapoints in the same cells
The only difference are the sheet's names.
So Basically "MoneyMarket" is just a name of one sheet of the workbook.
Tried using for each sheet but got kind of stuck of how to apply this
Dim YRange As Integer, ProjectionRange As Integer
Dim XRange As Range
Dim I As Integer
Sub DrawChart()
Set XRange = Sheets("MoneyMarket"). _
Range("R8:R" & Sheets("MoneyMarket").Range("R8").End(xlDown).Row)
ProjectionRange = Sheets("MoneyMarket").Range("T54").End(xlDown).Row
YRange = Sheets("MoneyMarket").Range("S8").End(xlDown).Row
Sheets("MoneyMarket").Range("S8:S" & YRange).Select
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:="MoneyMarket"
ActiveChart.SeriesCollection.Add Source:=Sheets("MoneyMarket").Range("T8:X" & YRange)
ActiveChart.ChartType = xlLine
ActiveChart.Axes(xlCategory).Select
ActiveChart.SeriesCollection(1).XValues = XRange
For I = 2 To 6
ActiveChart.SeriesCollection(I).Select
With Selection.Format.Line
.DashStyle = msoLineDash
End With
Next I
End Sub
a very quick search in Google will give you the answer on how to loop through all sheets in a workbook. This is just an example
Dim WS_Count As Integer
Dim I As Integer
' Set WS_Count equal to the number of worksheets in the active
' workbook.
WS_Count = ActiveWorkbook.Worksheets.Count
' Begin the loop.
For I = 1 To WS_Count
' Insert/Modify your code here. It will be applied to each sheet.
'For example to get their names
msgbox ActiveWorkbook.Worksheets(I).Name
Next I
If you are interested on a loop across some sheets in a workbook, I recommend you use an array like that:
Sub loopAcrossSheets()
temp = Array("Sheet1", "Sheet3", "SheetX")
For Each SheetName In temp
DrawChart (SheetName)
Next
End Sub
Then you should put the input string on your Sub:
Sub DrawChart(SheetName As String)
And, at last, replace the sheet name ("MoneyMarket") by SheetName!
This Works for me!
You have to create a Module, and refer directly to ActiveSheet in your code, check the code below
Dim YRange As Integer, ProjectionRange As Integer
Dim XRange As Range
Dim I As Integer
Public Sub DrawChart()
Dim ActiveSheetName as String
ActiveSheetName = ActiveSheet.Name
Set XRange = ActiveSheet. _
Range("R8:R" & ActiveSheet.Range("R8").End(xlDown).Row)
ProjectionRange = ActiveSheet.Range("T54").End(xlDown).Row
YRange = ActiveSheet.Range("S8").End(xlDown).Row
Sheets("MoneyMarket").Range("S8:S" & YRange).Select
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ActiveSheetName
ActiveChart.SeriesCollection.Add Source:=ActiveSheet.Range("T8:X" & YRange)
ActiveChart.ChartType = xlLine
ActiveChart.Axes(xlCategory).Select
ActiveChart.SeriesCollection(1).XValues = XRange
For I = 2 To 6
ActiveChart.SeriesCollection(I).Select
With Selection.Format.Line
.DashStyle = msoLineDash
End With
Next I
End Sub
Related
I need to create Bar chart in Excel VBA. I used the code below, but when I am ADDING or DELETING A ROW it is not working.
I need that chart on fixed range (K1). Because when I am calculating for the second time it creates another chart.
How can I change the code to prevent a new chart being added when I adjust the data source?
Private Sub CommandButton2_Click()
Sheets("Sheet7").Range("F2:H12").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlBarClustered
ActiveChart.SetSourceData Source:=Range("Sheet7!$F$2:$H$12")
ActiveChart.SeriesCollection(1).Name = "=Sheet7!$G$1"
ActiveChart.SeriesCollection(2).Name = "=Sheet7!$H$1"
End Sub
In the sample code below it checks to see if a chart called TheChart already exists, and if not, creates a new one. You can now add and remove rows and the chart should will update. Additionally, if you add a new row at the bottom and click the button it will redraw TheChart without creating a new one.
The chart is always located at the top-left of K1 per the rngChartTopLeft variable - which you can adjust if required.
The code assumes that it is running in a Sheet module (hence Set ws = Me) and if you were running it in a standard module you can set the sheet with Set ws = ThisWorkbook.Worksheets("your_sheet").
Option Explicit
Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim chto As ChartObject
Dim rngChartTopLeft As Range
Dim rngData As Range
' assumes the code is in a sheet object
Set ws = Me
' top left of chart
Set rngChartTopLeft = ws.Range("K1")
' create chart or get existing chart
If ws.ChartObjects.Count = 0 Then
Set chto = ws.ChartObjects.Add( _
Left:=rngChartTopLeft.Left, _
Width:=500, _
Top:=rngChartTopLeft.Top, _
Height:=500)
chto.Name = "TheChart"
Else
Set chto = ws.ChartObjects("TheChart")
End If
' set chart type
chto.Chart.ChartType = xlBarClustered
' get data range per last row of data
Set rngData = ws.Range("F2:G" & ws.Cells(ws.Rows.Count, "G").End(xlUp).Row)
' set new chart range
chto.Chart.SetSourceData rngData
End Sub
please check the below code:
Option Explicit
Private Sub CommandButton1_Click()
Dim mychart As Shape
Dim lastrow As Long
lastrow = Sheet7.Cells(Rows.Count, "F").End(xlUp).Row
For Each mychart In ActiveSheet.Shapes
If mychart.Name = "CommandButton1" Then GoTo exit_
mychart.Delete
exit_:
Next
Sheets("Sheet7").Range("F2:H" & lastrow).Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.ChartType = xlBarClustered
ActiveChart.SetSourceData Source:=Range("Sheet7!$F$2:$H$" & lastrow)
ActiveChart.SeriesCollection(1).Name = "=Sheet7!$G$1"
ActiveChart.SeriesCollection(2).Name = "=Sheet7!$H$1"
End Sub
I am trying to get this column to do a few things, but when it gets to wrap text and center it isn't doing it...it doesn't error but it doesn't wrap or center...any thoughts? ty in advance!
Sub Resize_Columns_And_Rows_No_Header()
'
'Resize_Columns_And_Rows Macro
'
'Declaration
Dim wkSt As String
Dim wkBk As Worksheet
Dim temp As Variant
Dim lastCol As Long
wkSt = ActiveSheet.Name
' This Loops Through All Sheets
For Each wkBk In ActiveWorkbook.Worksheets
On Error Resume Next
wkBk.Activate
lastCol = wkBk.Cells(1, Columns.Count).End(xlToLeft).Column
'This is only needed if you are wrapping the text
wkBk.Rows.WrapText = True
'This is to center align all rows
wkBk.Rows.VerticalAlignment = xlCenter
' Resize Columns
wkBk.Columns.EntireColumn.AutoFit
' Resize Rows
wkBk.Rows.EntireRow.AutoFit
Next wkBk
Sheets(wkSt).Select
End Sub
This worked for me.
The thing is though, WrapText = True and Columns.EntireColumn.AutoFit, sort of contradict each other.
Sub Resize_Columns_And_Rows_No_Header2()
Dim currentSheet As Worksheet
Set currentSheet = ActiveSheet
Dim sheet As Worksheet
For Each sheet In ActiveWorkbook.Worksheets
With sheet
With .Cells.Rows
.WrapText = True
.VerticalAlignment = xlCenter
.EntireRow.AutoFit
End With '.Cells.Rows
.Columns.EntireColumn.AutoFit
End With 'sheet
Next sheet
currentSheet.Activate
End Sub
By the way, do you also need a:
.HorizontalAlignment = xlCenter
?
I have the following VBA code that works to export a range of cells into a jpeg into a specified folder. I would like to have it loop through all worksheets in one workbook.
I need help looping this code through all open workbooks. I believe I will need to:
Dim WS As Worksheet, then set up an If statement, insert the below code, end the if statement, then at the end put a Next WS for it to actually loop through. My problem is, is that I keep getting a 91 error when I try to combine my if statement, For Each WS In ThisWorkbook.Sheets If Not WS.Name = "Sheet2" Then, with my code below.
The following code works in one worksheet at a time.
Sub ExportAsImage()
Dim objPic As Shape
Dim objChart As Chart
Dim i As Integer
Dim intCount As Integer
'copy the range as an image
Call ActiveSheet.Range("A1:F2").CopyPicture(xlScreen, xlPicture)
'remove all previous shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
'create an empty chart in the ActiveSheet
ActiveSheet.Shapes.AddChart
'select the shape in the ActiveSheet
ActiveSheet.Shapes.Item(1).Select
ActiveSheet.Shapes.Item(1).Width = Range("A1:F2").Width
ActiveSheet.Shapes.Item(1).Height = Range("A1:F2").Height
Set objChart = ActiveChart
'clear the chart
objChart.ChartArea.ClearContents
'paste the range into the chart
objChart.Paste
'save the chart as a JPEG
objChart.Export ("C:\Users\------\Desktop\Test\" & Range("B2").Value & ".jpg")
'remove all shapes in the ActiveSheet
intCount = ActiveSheet.Shapes.Count
For i = 1 To intCount
ActiveSheet.Shapes.Item(1).Delete
Next i
End Sub
Add this to your module:
Sub MAIN()
Dim sh As Worksheet
For Each sh In Sheets
sh.Activate
Call ExportAsImage
Next sh
End Sub
and run it. (there is no need to modify your code)
I'm writing a macro in VBA for Excel. I want it to replace all worksheets except for a few. First there is a loop which deletes the unwanted sheets, and then comes another one which creates new sheets to repace them! On a first run, the macro removes unwanted sheets. However, if it is run again it seems to be unable to delete the sheets it previously created, which causes a name duplicity error.
(The rng variable is supposed to extend across the entire row but I haven't gotten to fixing that yet.)
Hope you guys can provide some insight, much appreciated!
sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In Worksheets
If Not Current.Name = "Data" Then
Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
' Define range for loop
Dim rng As Range, cell As Range
Set rng = Sheets("Data").Range("A5:M5")
' Loop through entire row, looking for employees
For Each cell In rng
If cell.Value = "Nummer" Then
' Make new chart for employee
With Charts.Add
.ChartType = xlLineMarkers
.Name = cell.Offset(-1, 1).Value
.HasTitle = True
.ChartTitle.Text = cell.Offset(-1, 1).Value
' Set data (dynamic) and x-axis (static) for new chart
.SetSourceData Source:=Sheets("Data").Range(cell.Offset(-2, 3), cell.Offset(7, 4))
.Axes(xlValue).MajorGridlines.Select
.FullSeriesCollection(1).XValues = "=Data!E4:E12"
' Add trendlines
.FullSeriesCollection(1).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (DDE)"
.FullSeriesCollection(2).Trendlines.Add Type:=xlLinear, Forward _
:=0, Backward:=0, DisplayEquation:=0, DisplayRSquared:=0, Name:= _
"Trend (SDE)"
End With
' Chart is moved to end of all sheets
Sheets(cell.Offset(-1, 1).Value).Move _
after:=Sheets(Sheets.Count)
End If
Next cell
End Sub
No need to define the worksheet with the Worksheets()
Sub Terminator()
Dim Current As Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Worksheets
If Not Current.Name = "Data" Then
Current.Delete
End If
Next Current
Application.DisplayAlerts = True
End sub
The Following code (minor changes worked in my workbook), are you sure you have the names you put in the If in your Workbook ?
Anyway, I think it's better to use Select for multiple possible mathces
Sub Terminator()
Dim Current As Excel.Worksheet
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ActiveWorkbook.Sheets
If Not (Current.Name = "Data") Then
ActiveWorkbook.Worksheets(Current.Name).Delete
End If
Next Current
Application.DisplayAlerts = True
End Sub
Solution to the deletion is supplied by RGA, but in case you want to avoid several AND statements for each sheet that you want to retain, you can utilize a function similar to the isInArray below:
Sub Terminator()
Dim Current As Variant
Application.DisplayAlerts = False
' Loop through all of the worksheets in the active workbook.
For Each Current In ThisWorkbook.Sheets
If Not isInArray(Current.Name, Array("Data")) Then
Current.Delete
End If
Next
Application.DisplayAlerts = True
End Sub
Function isInArray(theValue As String, vArr As Variant) As Boolean
Dim vVal As Variant
isInArray = False
For Each vVal In vArr
If LCase(vVal) = LCase(theValue) Then
isInArray = True
End If
Next
End Function
EDIT:
function that takes a worksheet name as argument, and returns a worksheet object of that name. If the name is allready taken, the existing sheet is deleted and a new one created:
'example of use:
'set newWorksheet = doExist("This new Sheet")
Function doExist(strSheetName) As Worksheet
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsTest As Worksheet
Dim nWs As Worksheet
Set wsTest = Nothing
On Error Resume Next
'Set wsTest = wb.Worksheets(strSheetName) 'commented out in Edit of Edit
Set wsTest = wb.Sheets(strSheetName) 'as a comment for one of the other threads reveal, the error could be the deletion of Worksheets, which would be a subgroup to Sheets of which graph sheets are no a part
On Error GoTo 0
If Not wsTest Is Nothing Then
Application.DisplayAlerts = False
wsTest.Delete
Application.DisplayAlerts = True
End If
'Set doExist = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count)) 'Edit of Edit, the later call to Charts.Add does this for you
'doExist.Name = strSheetName 'Edit of Edit, no need to return anything
End Function
I need to activate a specific worksheet. The code is meant to create worksheets with a specif name. I need to paste something from a another worksheet into all these newly created worksheets. The code that I'm using is below. But I'm having a hard time activating the newly created worksheet to paste what I want.
Sub octo()
'Dim ws As Worksheet
Dim Ki As Range
Dim ListSh As Range
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\timesheet.xlsx")
With Worksheets("PPE 05-17-15")
Set ListSh = .Range("B4:B" & .Cells(.Rows.Count, "B").End(xlUp).Row)
End With
On Error Resume Next
For Each Ki In ListSh
If Len(Trim(Ki.Value)) > 0 Then
If Len(Worksheets(Ki.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value
'open template
Workbooks.Open ("C:\Users\Dash\Dropbox\Randika\Misc\Emmash timesheets\octo_template.xls")
Range("A1:L31").Select
Selection.Copy
Worksheets(Ki.Value).Activate
If ThisWorkbook.Saved = False Then
ThisWorkbook.Save
End If
End If
End If
Next Ki
End Sub
Both Workbooks.Open and Worksheets.Add return references to the opened and added objects, which you can use to directly access and modify them - and in your case, to paste data.
Example:
Dim oSourceSheet As Worksheet
Dim oTargetSheet As Worksheet
Set oSourceSheet = Sheet1 'Set reference to any sheet, Sheet1 in my example
Set oTargetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
oSourceSheet.Range("A1:L31").Copy
oTargetSheet.Paste
Set oSourceSheet = Nothing
Set oTargetSheet = Nothing
I think that is what you need. As what been mentioned by chris, there is no need Activate or Select. Hope the following code solve your problem.
Option Explicit
Dim MyTemplateWorkbook As Workbook
Dim MyDataWorkbook As Workbook
Dim MyTemplateWorksheet As Worksheet
Dim MyDataWorksheet As Worksheet
Dim MyNewDataWorksheet As Worksheet
Dim CurrentRange As Range
Dim ListRange As Range
Sub AddWSAndGetData()
Set MyTemplateWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyTemplate.xlsx")
Set MyTemplateWorksheet = MyTemplateWorkbook.Sheets("Template")
Set MyDataWorkbook = Workbooks.Open("C:\Users\lengkgan\Desktop\Testing\MyData1.xlsx")
Set MyDataWorksheet = MyDataWorkbook.Sheets("PPE 05-17-15")
Set ListRange = MyDataWorksheet.Range("B4:B" & MyDataWorksheet.Cells(Rows.Count, "B").End(xlUp).Row)
Application.ScreenUpdating = False
On Error Resume Next
For Each CurrentRange In ListRange
If Len(Trim(CurrentRange.Value)) > 0 Then
If Len(MyDataWorksheet(CurrentRange.Value).Name) = 0 Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CurrentRange.Value
Set MyNewDataWorksheet = MyDataWorkbook.Sheets(ActiveSheet.Name)
MyNewDataWorksheet.Range("A1:L31").Value = MyTemplateWorksheet.Range("A1:L31").Value
If MyDataWorkbook.Saved = False Then
MyDataWorkbook.Save
End If
End If
End If
Next CurrentRange
MyTemplateWorkbook.Close (False) 'Close the template without saving
End Sub