I am having an issue referencing ranges in my vba program. The following snippet of code shows my original code:
With Worksheets("Overall 6 mo")
.Columns("A:G").ColumnWidth = 13.57
.Range("A1:Z100").Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
End With
This would throw the "runtime 1004 application-defined or object-defined error" after going through line 3.
So then, I changed
.Range("A1:Z100").Rows.RowHeight = 15
to
.Rows.RowHeight = 15
The point was to make the cells that i need to use have a height of 15 so the change didn't hurt my program. And now, it will allow that but then throw the same error at the next line, where I reference a range again. So I'm trying to figure out why it won't allow me to use .range ? Or at least how I can fix it?
UPDATE:
I have come to realize that I cannot use the .Range method anywhere in my workbook (not just in the instance above). What would disable me to use .Range everywhere?
UPDATE2:
It will now no longer let me use the .Columns method in the second line. I haven't done anything but step through it a couple times. What is wrong with this thing?
UPDATE3:
It seems that when i restart excel, it will allow me to run the worksheet "Overall 6 mo" code once, and then starts throwing the error every time after that. I've included the code for the rest of the sheet.
Option Explicit
Private Sub Worksheet_Activate()
Application.ScreenUpdating = False
Dim shIndex As Integer
Dim rowIndex As Integer
Dim myLastRow As Integer
Dim shLastRow As Integer
Dim col As Integer
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 1).End(xlUp).Row
' Format Worksheet
Sheets("Overall 6 mo").Cells.Clear
With Worksheets("Overall 6 mo")
.Columns.ColumnWidth = 13.57
.Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
End With
' Clear current sheet data
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 2).End(xlUp).Row
Worksheets("Overall 6 mo").Range(Cells(4, 1), Cells(myLastRow, 7)).Clear
' Compile data from last six months and add to and display on "Overall 6 mo" sheet
For shIndex = Worksheets.Count - 5 To Worksheets.Count
Worksheets(shIndex).Activate
myLastRow = Worksheets("Overall 6 mo").Cells(65536, 2).End(xlUp).Row
shLastRow = Worksheets(shIndex).Cells(65536, 1).End(xlUp).Row
Worksheets("Overall 6 mo").Cells(myLastRow + 1, 1).Value _
= MonthName(Month(CDate(Worksheets(shIndex).Name)), False)
Worksheets(shIndex).Range("A4:D" & shLastRow) _
.Copy (Worksheets("Overall 6 mo").Cells(myLastRow + 1, 2))
Next shIndex
' Call UpdateChart to clear and re-add Quality and Cost charts to wks
Call UpdateCharts(Worksheets("Overall 6 mo").Index)
Worksheets("Overall 6 mo").Activate
Application.ScreenUpdating = True
End Sub
You can do row height changes with:
.Range("A1:Z100").RowHeight = 15
And can you use Range Copy method
Worksheets("TEMPLATE").Range("A3:F3").Copy .Range("B3")
Worksheets("TEMPLATE").Range("E4:F100").Copy .Range("F4")
UPDATE:
Option Explicit
Private Sub Worksheet_Activate()
Dim oSh As Worksheet
Dim shIndex As Long
Dim rowIndex As Long
Dim myLastRow As Long
Dim shLastRow As Long
Application.ScreenUpdating = False
Set oSh = ThisWorkbook.Worksheets("Overall 6 mo")
' Format Worksheet
With oSh
.Cells.Clear
.Columns.ColumnWidth = 13.57
.Rows.RowHeight = 15
.Columns("F:G").NumberFormat = "0.00%"
.Range("A1").NumberFormat = "#"
.Range("A1") = .Name
.Range("B3:G3") = Worksheets("TEMPLATE").Range("A3:F3").Value
.Range("F4:G100") = Worksheets("TEMPLATE").Range("E4:F100").Formula
End With
' Clear current sheet data
oSh.Range(oSh.Cells(4, 1), oSh.Cells(GetLastRow(oSh, 2), 7)).Clear
' Compile data from last six months and add to and display on "Overall 6 mo" sheet
For shIndex = Worksheets.Count - 5 To Worksheets.Count
'Worksheets(shIndex).Activate
myLastRow = GetLastRow(oSh, 2)
shLastRow = GetLastRow(Worksheets(shIndex), 1)
oSh.Cells(myLastRow + 1, 1).Value = MonthName(Month(CDate(Worksheets(shIndex).Name)), False)
Worksheets(shIndex).Range("A4:D" & shLastRow).Copy oSh.Cells(myLastRow + 1, 2)
Next shIndex
' Call UpdateChart to clear and re-add Quality and Cost charts to wks
Call UpdateCharts(oSh.Index)
oSh.Activate
Set oSh = Nothing
Application.ScreenUpdating = True
End Sub
Private Function GetLastRow(oSheet As Worksheet, lngColumn As Long) As Long
GetLastRow = oSheet.Cells(oSheet.UsedRange.SpecialCells(xlLastCell).Row + 1, lngColumn).End(xlUp).Row
End Function
Is "TEMPLATE" in the same workbook with Index 1 (or less than Worksheets.Count - 5)? I have comment out Worksheets(shIndex).Activate as seems no need to run this sub every time in the For loop.
RowHeight applies to whole rows, not parts of rows.
So use
.Range("A1:A100").EntireRow.RowHeight = 15
or
.Range("1:100").RowHeight = 15
Related
I'm using a VBA to copy all the unique values from one sheet to another sheet. My VBA looks like this:
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, 1
End If
Next
Sheet3.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
Application.ScreenUpdating = True
End Sub
This takes all the unique values from Sheet 1 column B and moves them to sheet 3 column A. What I'm now trying to add is a function that takes the same rows from column C in sheet 1 and paste them into sheet 3 column B.
Is there an easy way to add this to the existing VBA?
please check this:
Option Explicit
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
On Error Resume Next
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
dictionary.Add shee.Cells(i, "B").Value, shee.Cells(i, "c").Value
End If
Next
With Sheet3
.Range("A3").Resize(dictionary.Count).Value = _
Application.Transpose(dictionary.keys)
For i = 1 To dictionary.Count
.Cells(i + 2, 2) = dictionary(Sheet3.Cells(i + 2, 1).Value)
Next
End With
Application.ScreenUpdating = True
End Sub
If you just want one column you can utilise the Item. I prefer to avoid the "On Error" statement - the method below will not error if the same key is used (it will just overwrite).
Sub UniqueListSample()
Application.ScreenUpdating = False
Dim lastrow As Long
Dim i As Long
Dim dictionary As Object
Dim shee As Worksheet
Set dictionary = CreateObject("scripting.dictionary")
Set shee = ThisWorkbook.Sheets("Sheet1")
lastrow = shee.Cells(Rows.Count, "B").End(xlUp).Row
With dictionary
For i = 1 To lastrow
If Len(Sheet1.Cells(i, "B")) <> 0 Then
If Not (.Exists(shee.Cells(i, "B").Value)) Then
.Item(shee.Cells(i, "B").Value) = shee.Cells(i, "C").Value
End If
End If
Next
Sheet3.Range("A3").Resize(.Count).Value = Application.Transpose(.keys)
Sheet3.Range("B3").Resize(.Count).Value = Application.Transpose(.items)
End With
Application.ScreenUpdating = True
End Sub
I want to compare three worksheets (which should be identical) in a workbook and highlight any non-matching cells. I've based the following code on Using VBA to compare two Excel workbooks:
Sub CompareWorksheets()
Dim varSheetA As Worksheet
Dim varSheetB As Worksheet
Dim varSheetC As Worksheet
Dim varSheetAr As Variant
Dim varSheetBr As Variant
Dim varSheetCr As Variant
Dim strRangeToCheck As String
Dim iRow As Long
Dim iCol As Long
Set varSheetA = Worksheets("DS")
Set varSheetB = Worksheets("HT")
Set varSheetC = Worksheets("NM")
strRangeToCheck = ("A1:L30")
' If you know the data will only be in a smaller range, reduce the size of the ranges above.
varSheetAr = varSheetA.Range(strRangeToCheck).Value
varSheetBr = varSheetB.Range(strRangeToCheck).Value
varSheetCr = varSheetC.Range(strRangeToCheck).Value ' or whatever your other sheet is.
For iRow = LBound(varSheetAr, 1) To UBound(varSheetAr, 1)
For iCol = LBound(varSheetAr, 2) To UBound(varSheetAr, 2)
Debug.Print iRow, iCol
If varSheetAr(iRow, iCol) = varSheetBr(iRow, iCol) And varSheetAr(iRow, iCol) = varSheetCr(iRow, iCol) Then
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = xlNone
varSheetC.Cells(iRow, iCol).Interior.ColorIndex = xlNone
Else
varSheetA.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetB.Cells(iRow, iCol).Interior.ColorIndex = 22
varSheetC.Cells(iRow, iCol).Interior.ColorIndex = 22
End If
Next
Next
End Sub
The problem is, when "strRangeToCheck" starts at A1, everything works as it should, but as soon as I change the range to something like ("B4:C6"), it looks like the correct comparisons are still being made, but the cells that get highlighted always get shifted back up to cell A1 as the starting point (as opposed to B4, which is what I want). In other words, the highlighting "pattern" is correct, but shifted up and over a few cells.
I expanded on #Vityata example.
CompareWorksheets compares the same range on up to up to 60 Worksheets, whereas CompareRanges will compare ranges of the same size and shape.
Sub Test_Comparisons()
CompareWorksheets "A1:L30", Worksheets("DS"), Worksheets("HT"), Worksheets("NM")
CompareRanges Worksheets("DS").Range("A1:L30"), Worksheets("HT").Range("K11:V40"), Worksheets("NM").Range("A101:L130")
End Sub
Sub CompareWorksheets(CompareAddress As String, ParamArray arrWorkSheets() As Variant)
Application.ScreenUpdating = False
Dim cell As Range
Dim x As Long
Dim bFlag As Boolean
'Reset all the colors
For x = 0 To UBound(arrWorkSheets)
arrWorkSheets(x).Range(CompareAddress).Interior.ColorIndex = xlNone
Next
For Each cell In arrWorkSheets(0).Range(CompareAddress)
bFlag = False
For x = 1 To UBound(arrWorkSheets)
If arrWorkSheets(x).Range(cell.ADDRESS).Value <> cell.Value Then
bFlag = True
Exit For
End If
Next
If bFlag Then
For x = 0 To UBound(arrWorkSheets)
arrWorkSheets(x).Range(cell.ADDRESS).Interior.ColorIndex = 22
Next
End If
Next
Application.ScreenUpdating = True
End Sub
Sub CompareRanges(ParamArray arrRanges() As Variant)
Application.ScreenUpdating = False
Dim cell As Range
Dim x As Long, y As Long, z As Long
Dim bFlag As Boolean
'Reset all the colors
For z = 0 To UBound(arrRanges)
arrRanges(z).Interior.ColorIndex = xlNone
Next
For x = 1 To arrRanges(0).Rows.Count
For y = 1 To arrRanges(0).Rows.Count
For z = 1 To UBound(arrWorkSheets)
If arrWorkSheets(1).Cells(x, y).Value <> arrWorkSheets(z).Cells(x, y).Value Then
bFlag = True
Exit For
End If
Next
If bFlag Then
For z = 0 To UBound(arrWorkSheets)
arrWorkSheets(z).Cells(x, y).Interior.ColorIndex = 22
Next
End If
Next
Next
Application.ScreenUpdating = True
End Sub
What I have understood from the first reading, is that you have 3 worksheets which you want to compare. This code works, if you want to compare a selected range in the first three worksheets in a workbook. It colors the different values in red, in each workbook:
Option Explicit
Sub compareWorksheets()
Dim rngCell As Range
Dim counter As Long
For Each rngCell In Selection
If Worksheets(1).Range(rngCell.Address) <> Worksheets(2).Range(rngCell.Address) _
Or Worksheets(1).Range(rngCell.Address) <> Worksheets(3).Range(rngCell.Address) Then
For counter = 1 To 3
Worksheets(counter).Range(rngCell.Address).Interior.Color = vbRed
Next counter
End If
Next rngCell
End Sub
If you want to compare a range A1:Z10 in the three worksheets, change the words Selection with Worksheets(1).Range("A1:Z10") or simply select the range in a one workbook.
I'm writing an excel VBA script to loop through a set of 4 sheets, find a string at the top of a column of data, loop through all the data in that column and print the header and data in a summary tab.
I'm new to VBA and even after extensive research can't figure out why I'm getting Runtime error 1004 "Application-defined or object-defined error."
Here is the VBA code:
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, sheet As Worksheet, i As Integer, j As Integer, Summary As Worksheet
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
'Loop through each sheet looking for the right header
For Each sheet In Workbooks("Tab Extraction Test.xlsm").Worksheets
i = i + 1
'Debug.Print i
'Debug.Print HeaderList(i)
Set h = Cells.Find(What:=HeaderList(i))
With Worksheets("Summary")
Worksheets("Summary").Cells(1, i).Value = h
End With
Col = h.Column
Debug.Print Col
Row = h.Row
Debug.Print Row
j = Row
'Until an empty cell in encountered copy the value to a summary tab
Do While IsEmpty(Cells(Col, j)) = False
j = j + 1
V = Range(Col, j).Value
Debug.Print V
Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary").Cells(j, i).Value = V
Loop
Next sheet
End Sub
The error occurs at
Worksheets("Summary").Cells(1, i).Value = h
From other posts I thought this might be because I was trying to add something to a different cell than the one that was active in the current loop so I added a With statement but to no avail.
Thank you in advance for your help.
Following the comments above, try the code below.
Note: I think your Cells(Row, Col) is mixed-up, I haven't modified it yet in my answer below. I think Cells(Col, j) should be Cells(j, Col) , no ?
Code
Option Explicit
Private Sub CommandButton1_Click()
Dim HeaderList(1 To 4) As String, ws As Worksheet, i As Long, j As Long, Summary As Worksheet
Dim h As Range, Col As Long
'Define headers to look for
HeaderList(1) = "Bananas"
HeaderList(2) = "Puppies"
HeaderList(3) = "Tigers"
' set the "Summary" tab worksheet
Set Summary = Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary")
'Loop through each sheet looking for the right header
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
With ws
i = i + 1
Set h = .Cells.Find(What:=HeaderList(i))
If Not h Is Nothing Then ' successful find
Summary.Cells(1, i).Value = h.Value
j = h.Row
'Until an empty cell in encountered copy the value to "Summary" tab
' Do While Not IsEmpty(.Cells(h.Column, j))
Do While Not IsEmpty(.Cells(j, h.Column)) ' <-- should be
j = j + 1
Summary.Cells(j, i).Value = .Cells(j, h.Column).Value
Loop
Set h = Nothing ' reset range object
End If
End With
Next ws
End Sub
Try this one.
Private Sub CommandButton1_Click()
Dim HeaderList As Variant, ws As Worksheet, i As Integer, j As Integer, Summary As Worksheet
Dim lastRow As Long, lastCol As Long, colNum As Long
HeaderList = Array("Bananas", "Puppies", "Tigers", "Lions")
For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
lastCol = ws.Range("IV1").End(xlToLeft).Column
For k = 1 To lastCol
For i = 0 To 3
Set h = ws.Range(Chr(k + 64) & "1").Find(What:=HeaderList(i))
If Not h Is Nothing Then
lastRow = ws.Range(Chr(h.Column + 64) & "65536").End(xlUp).Row
colNum = colNum + 1
' The below line of code adds a header to summary page (row 1) showing which workbook and sheet the data came from
' If you want to use it then make sure you change the end of the follpowing line of code from "1" to "2"
' ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1").Value = Left(ws.Parent.Name, Len(ws.Parent.Name) - 5) & ", " & ws.Name
ws.Range(Chr(h.Column + 64) & "1:" & Chr(h.Column + 64) & lastRow).Copy Destination:=ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1")
Exit For
End If
Next i
Next k
Next ws
End Sub
Sometimes you have to remove blank sheets. Say you have 2k sheets because you combined a bunch of txt files into one workbook. But they're all in one column. So you loop through to do a text2columns. It does some of them but not all of them. It stops to give you run-time error 1004. Try removing blank sheets before looping through to do text2columns or something else.
Sub RemoveBlankSheets_ActiveWorkbook()
'PURPOSE: Delete any blanks sheets in the active workbook
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim sht As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In ActiveWorkbook.Worksheets
If WorksheetFunction.CountA(sht.Cells) = 0 And _
ActiveWorkbook.Sheets.Count > 1 Then sht.Delete
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I'm writing a simple formatting macro to alternate the row color for a table in Excel.
I want this macro to be able to format any size table (no matter row/column size).
For example, I want the macro to work when I have a chart with 6 rows 4 columns, or 4 rows 5 columns, or 9 rows 10 columns, etc.
Here's the code I have so far - but I'm getting a runtime error.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For Each Cell In Range(lastRow, lastCol) ''change range accordingly
If Cell.Row Mod 2 = 1 Then
Cell.Interior.ColorIndex = 15 ''color to preference
Else
Cell.Interior.ColorIndex = 14 ''color to preference or remove
End If
Next Cell
End If
I've tried multiple versions of the Range - having the column var come first, having an '&' instead of a comma, etc.
If I use just Range("A1:A" & lastRow), it'll work but just for the data in column A.
I would need it to span across all columns in the chart.
If the tables are all starting from cell A1, change your for statement to:
For Each Cell In Range("A1", Cells(lastRow, lastCol)) ''change range accordingly
Though also, the way your for loop works is that it is changing every cell. It can be optimized to color the row up to the last column at once.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
Dim i As Integer
For i = 1 To lastRow
If i Mod 2 = 1 Then
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 15
Else
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 14
End If
Next i
End If
Try this:
Dim r As Range
For Each r In MyWs.UsedRange.Rows
If r.Row Mod 2 = 1 Then
r.Interior.ColorIndex = 15
Else
r.Interior.ColorIndex = 14
End If
Next r
Always good to include Option Explicit in your code modules. Try the following:
Option Explicit
Sub test()
Dim MyWS As Excel.Worksheet
Dim objRow As Excel.Range
Dim lastCol As Long
Dim lastRow As Long
Dim lngRow As Long
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For lngRow = 1 To lastRow
Set objRow = MyWS.Range(MyWS.Cells(lngRow, 1), MyWS.Cells(lngRow, lastCol))
If lngRow Mod 2 = 1 Then
objRow.Interior.ColorIndex = 15 'color to preference
Else
objRow.Interior.ColorIndex = 14 'color to preference or remove
End If
Next lngRow
End If
End Sub
Here is my problem. I managed to create a macro that looks like this:
Sub Macro1()
Range("G17:G36").Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=Range("'Sheet1'!$G$17:$G$36")
ActiveChart.ChartType = xlLine
End Sub
I know this was pretty basic to record but my problem is how to change it and make the range dynamic and conditional. For example when I get to the row 17 I have a value in the cell D17 that is greater than lets say 200 and a value in E17 greater than 100. This should trigger the beginning of my range. So if D17>200 AND E17>100 I need to get G17 as the beginning of the range. As for G36 (the end of the range) the logic is very similar but this time I would test for a condition like this: IF F36<64 THEN get G36 as the end of the range.
The should repeat till the end. For example the last row could be at 28000 so I expect a good few of these charts to be created along the way.
Thanks is advance for your help,
Schroedinger.
This is how it looks now and gives me a run-time error explained in my correspondence with EngJon.
Sub GenerateCharts()
Application.ScreenUpdating = False
'Get the last row
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim endOfRange As Long
Dim wholeRange As Range
Dim i As Long
For i = 1 To LastRow
If Cells(i, 4) > 0.000001 And Cells(i, 5) > 0.00000002 Then
'Determine the end of the range
endOfRange = DetermineRange(i)
Set wholeRange = Range(Cells(i, 7), Cells(endOfRange, 7))
NewChart (wholeRange)
i = endOfRange
End If
Next i
Application.ScreenUpdating = True
End Sub
Function DetermineRange(row As Long) As Long
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim j As Long
For j = row To LastRow
If Cells(j, 6) < -0.0000000018 Then
DetermineRange = j
Exit Function
End If
Next j
DetermineRange = j
End Function
Function NewChart(rng As Range)
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rng
ActiveChart.ChartType = xlLine
End Function
This is a final solution for me. I hope it helps someone. Big tnx to EngJon and Paagua Grant.
Sub GenerateCharts()
Application.ScreenUpdating = False
Dim StartCell As Long
Dim EndCell As Long
Dim ChartRange As Range
Dim DataEnd As Long
Dim i As Integer
Dim j As Integer
Dim HasStart As Boolean
Dim HasEnd As Boolean
'Sets end of data based on the row you are charting
DataEnd = Cells(Rows.Count, 7).End(xlUp).Row
'Begin loop to find start and end ranges, create charts based on those ranges
For i = 1 To DataEnd
If HasStart Then
If Cells(i, 4).Value < 0 Then
EndCell = i
HasEnd = True
End If
Else 'If there isn't a starting cell yet
If Cells(i, 4).Value > 0.000001 And Cells(i, 5).Value > 0.00000002 Then
StartCell = i
HasStart = True
End If
End If
If HasStart And HasEnd Then
Set ChartRange = ActiveSheet.Range(Cells(StartCell, 7), Cells(EndCell, 7))
ActiveSheet.Shapes.AddChart(xlLine, _
Left:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 10)).Left, _
Top:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 10)).Top, _
Width:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell, 20)).Width, _
Height:=ActiveSheet.Range(Cells(StartCell, 10), Cells(StartCell + 25, 10)).Height _
).Select
ActiveChart.SetSourceData Source:=ChartRange
HasStart = False
HasEnd = False
End If
Next
Application.ScreenUpdating = True
End Sub
You can use your recorded Macro1 as a Function and call it when you need to create a new Chart:
Function NewChart(rng As Range)
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rng
ActiveChart.ChartType = xlLine
End Function
You will also need the following function:
Function DetermineRange(row As Long) As Long
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim j As Long
For j = row To LastRow
If Cells(j, 6) < 64 Then
DetermineRange = j
Exit Function
End If
Next j
DetermineRange = j
End Function
You will call it in a Sub that iterates over all rows:
Sub GenerateCharts()
Application.ScreenUpdating = False
'Get the last row
Dim LastRow As Long
LastRow = ActiveSheet.UsedRange.Rows.Count
Dim endOfRange As Long
Dim wholeRange As Range
Dim i As Long
For i = 1 To LastRow
If Cells(i, 4) > 200 And Cells(i, 5) > 100 Then
'Determine the end of the range
endOfRange = DetermineRange(i)
Set wholeRange = Range(Cells(i, 7), Cells(endOfRange, 7))
NewChart wholeRange
i = endOfRange
End If
Next i
Application.ScreenUpdating = True
End Sub
Copy those three in a module and execute the Sub. Please comment if this did what you needed.
Here's a slightly different option that performs all of the tasks in a single function.
Option Explicit
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Dim StartCell As Long, EndCell As Long, ChartRange As Range, DataEnd As Long, i As Integer, j As Integer, HasStart As Boolean, HasEnd As Boolean, _
ChartTop As Long, ChartHeight As Long
DataEnd = Cells(Rows.Count, 7).End(xlUp).Row 'Sets end of data based on the row you are charting.
ChartTop = 50
ChartHeight = 100
'Begin loop to find start and end ranges, create charts based on those ranges.
For i = 1 To DataEnd
If HasStart Then
If Cells(i, 6).Value < 64 Then
EndCell = i
HasEnd = True
End If
Else 'If there isn't a starting cell yet.
If Cells(i, 7).Value > 200 And Cells(i, 5).Value > 100 Then
StartCell = i
HasStart = True
End If
End If
If HasStart And HasEnd Then
Set ChartRange = ActiveSheet.Range(Cells(StartCell, 7), Cells(EndCell, 7))
ActiveSheet.Shapes.AddChart(Top:=ChartTop, Height:=ChartHeight).Select
With ActiveChart
.SetSourceData Source:=ChartRange
.ChartType = xlLine
End With
ChartTop = ChartTop + ChartHeight + 15
HasStart = False
HasEnd = False
End If
Next
Application.ScreenUpdating = True
End Sub
This also makes sure that each chart created by the tool does not overlap the previous chart.
For the sake of space and clarity, I am putting my response to your followup questions here.
Assuming standard row heights and column widths, you can set
ChartTop =(StartCell-1)*15
to set the top of the chart to begin at the top of the same row as your data, and within the
ActiveSheet.Shapes.AddChart(Top:=ChartTop, Height:=ChartHeight).Select
you can add
Left:=(X * 48)
where X is one less than the column number that you want the chart to be left-aligned to, e.g. if you want the chart to start at the left edge of Column I, X would be equal to 8. However, as far as I can tell, there is no easy way to adjust these values if your row height/column widths is non-standard, e.g. if you have auto-fit your columns to your data.