I recorded a macro and it resulted in the following code which worked as desired:
ActiveSheet.Shapes.AddChart2(227, xlLine).Select
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).Name = "=Graph!$B$1"
ActiveChart.FullSeriesCollection(1).Values = "=Graph!$B$3:$B$170"
ActiveChart.FullSeriesCollection(1).XValues = "=Graph!$A$3:$A$170"
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(2).Name = "=Graph!$H$1"
ActiveChart.FullSeriesCollection(2).Values = "=Graph!$H$3:$H$367"
ActiveChart.FullSeriesCollection(2).XValues = "=Graph!$G$3:$G$367"
I built my code around that macro as such:
Dim LastRow As Long, LastRow1 As Long, LastRow2 As Long
Dim P1Rating As Range
Dim P2Rating As Range
Dim DateRange As Range
Dim ShName As String
With ActiveSheet
' gets the lengths of each row
LastRow1 = .Range("B" & .Rows.Count).End(xlUp).Row
LastRow2 = .Range("G" & .Rows.Count).End(xlUp).Row
' checks to see which one is longer
If LastRow1 >= LastRow2 Then
LastRow = LastRow1
Else
LastRow = LastRow2
End If
' assigns the longer count to each range
Set P1Rating = .Range("B3:B" & LastRow)
Set date1range = .Range("A3:A" & LastRow)
Set P2Rating = .Range("H3:H" & LastRow)
Set date2range = .Range("G3:G" & LastRow)
ShName = .Name
End With
ActiveSheet.Shapes.AddChart2(227, xlLine, 600, 20).Select
indexofchart = ActiveChart.Parent.Index
ActiveSheet.ChartObjects(indexofchart).Activate
ActiveChart.HasTitle = True
ActiveChart.ChartTitle.Text = P1Name & " vs " & P2Name
ActiveChart.HasLegend = True
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(1).Name = P1Name
ActiveChart.FullSeriesCollection(1).Values = P1Rating
ActiveChart.FullSeriesCollection(1).XValues = date1range
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(2).Name = P2Name
ActiveChart.FullSeriesCollection(2).Values = P2Rating
ActiveChart.FullSeriesCollection(2).XValues = date2range
I am using :
If LastRow1 >= LastRow2 Then
LastRow = LastRow1
Else
LastRow = LastRow2
to force using the largest range for all of the variables and verified the proper value is used.
As you can see, I simply replaced the hard ranges from the macro with the variables
Unfortunately, if date1range is a smaller range, then the graph stops at that point (Both series are shown 100% across the graph, but any data from series 2 past that point is lost)
But in the recording, that series is only 167 long as well and the graph displays the whole 364 entries (the longer range). with the first series ending 1/3 of the way across the graph
If that range is the larger one, then it displays as expected.
Short of forcing the graph to use the longer range first, what can I do?
I found a simple and elegant solution that should work wonderfully. I found the answer here:https://peltiertech.com/plot-two-time-series-with-different-dates/
Simply put all date values into one column!
| 9/15/2015 | 1400 | a | | | | | | |
| 9/16/2015 | 1398 | a | | | | | | |
| 9/16/2015 | 1399 | d | | | | | | |
| 9/20/2015 | 1401 | b | | | | | | |
| 9/15/2015 | | | 1400 | a | | | | |
| 9/15/2015 | | | 1398 | c | | | | |
| 9/20/2015 | | | 1406 | c | | | | |
| 9/20/2015 | | | 1407 | d | | | | |
| 9/20/2015 | | | 1408 | b | | | | |
Related
I'm trying to set up a nested loop that can tie together different columns only when the column in question has data.
What I have is a table like this:
|Aname |aterm |amod |
| | | |
|Smith, Bob | | |
| | | |
| | | |
| | 2/6/2017| |
| | | |
| | |Module 1 |
| | | |
|Smith, John | | |
| | | |
| | | |
| |5/12/2017| |
| | |Module 6 |
| | | |
| | |Module 4 |
| | | |
| |6/12/2017| |
| | | |
| | |Module 10|
| | |Module 5 |
What I am trying to do is tie the columns together like so:
|aname |aterm |amod |
|Smith, Bob | 02/6/2017 | Module 1 |
|Smith, John | 5/12/2014 | Module 6 |
|Smith, John | 5/12/2014 | Module 4 |
|Smith, John | 6/12/2014 | Module 10 |
|Smith, John | 6/12/2014 | Module 5 |
Below is the code I put together to pull this off. Unfortunately, the printing is picking up the aname dozens of time, the aterm intermittently, and the amod not at all.
Sub looper()
Dim rng As Range
Dim rng2 As Range
Dim rng3 As Range
aname = ""
aterm = ""
amod = ""
Set listenroll = [table1[aname]]
Set atermrange = [table1[aterm]]
Set amodrange = [table1[amod]]
For Each rng In listenroll
If IsEmpty(rng) = False Then
Set aname = rng
For Each rng2 In atermrange
If IsEmpty(rng2) = False Then
Set aterm = rng2
For Each rng3 In amodrange
If IsEmpty(rng3) = False Then
Set amodrange = rng3
Range("I1").End(xlDown).Offset(1, 0) = aname
Range("J1").End(xlDown).Offset(1, 0) = aterm
Range("K1").End(xlDown).Offset(1, 0) = amod
End If
Next rng3
End If
Next rng2
End If
Next rng
Does anyone know what the problem is here?
I have an alternative solution for you. This is basically the same thing with YowE3K's code, however there is one more for loop and one less if statement. This is because, instead of using table names I used column A B C assuming your table is there, and also stored the values in an array.
Try this:
Sub looper()
Dim i As Long, j As Long, LastCell As Long
Dim arr() As String
ReDim arr(2)
With Sheets("Sheet1")
LastCell = .UsedRange.Rows.Count
For i = 2 To LastCell
For j = 1 To 3
If Not IsEmpty(.Cells(i, j)) Then
arr(j - 1) = .Cells(i, j)
If j = 3 Then
.Cells(.Rows.Count, "I").End(xlUp).Offset(1, 0) = arr(0)
.Cells(.Rows.Count, "J").End(xlUp).Offset(1, 0) = arr(1)
.Cells(.Rows.Count, "K").End(xlUp).Offset(1, 0) = arr(2)
End If
End If
Next j
Next i
End With
End Sub
You only need one loop:
Sub looper()
Dim aname As String
'Dim aterm As String
Dim aterm As Date
Dim amod As String
aname = ""
'aterm = ""
aterm = 0
amod = ""
Set listenroll = [table1[aname]]
Set atermrange = [table1[aterm]]
Set amodrange = [table1[amod]]
Dim r As Long
For r = 1 to amodrange.Rows.Count
'Record value of AName whenever it changes
If Trim(listenroll(r, 1).Value) <> vbNullString Then
aname = Trim(listenroll(r, 1).Value)
End If
'Record value of ATerm whenever it changes
If Trim(atermrange(r, 1).Value) <> vbNullString Then
'aterm = Trim(atermrange(r, 1).Value)
aterm = CDate(atermrange(r, 1).Value)
End If
'Write output each time there is something in amod
If Trim(amodrange(r, 1).Value) <> vbNullString Then
amod = Trim(amodrange(r, 1).Value)
Range("I1").End(xlDown).Offset(1, 0) = aname
Range("J1").End(xlDown).Offset(1, 0) = aterm
Range("K1").End(xlDown).Offset(1, 0) = amod
End If
Next
Note: I'm not sure how to modify aterm to match your question's example, but I'm hoping that's just a typo in the example.
And, FWIW, you have one major error in your existing code at the point where you say Set amodrange = rng3. I'm not sure whether that is the only error.
I am trying to remove only empty lines from cells in excel. Here is what I'm trying to accoplish:
+-----------------+ +---------------------+ +---------------------+
| EXAMPLE DATA | | EXPLANATION | | EXPECTED RESULT |
+-----------------+ +---------------------+ +---------------------+
| cell1_text1 | | cell1_text1 | | cell1_text1 |
| cell1_text2 | | cell1_text2 | | cell1_text2 |
+-----------------+ +---------------------+ +---------------------+
| | | cell2_empty_line | | cell2_text1 |
| cell2_text1 | | cell2_text1 | +---------------------+
+-----------------+ +---------------------+ | cell3_text1 |
| cell3_text1 | | cell3_text1 | | cell3_text2 |
| | | cell3_emptyline | +---------------------+
| cell3_text2 | | cell3_text2 | | cell4_text1 |
+-----------------+ +---------------------+ +---------------------+
| | | cell4_emptyline | | cell5_text1 |
| | | cell4_emptyline | +---------------------+
| cell4_text1 | | cell4_text1 | | cell6_text1 |
+-----------------+ +---------------------+ | cell6_text2 |
| cell5_text1 | | cell5_text1 | | cell6_text3 |
+-----------------+ +---------------------+ | cell6_text4 |
| cell6_text1 | | cell6_text1 | +---------------------+
| cell6_text2 | | cell6_text2 |
| cell6_text3 | | cell6_text3 |
| | | cell6_emptyline |
| cell6_text4 | | cell6_text4 |
+-----------------+ +---------------------+
I have found this script:
Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
but it doesn't give me desired result, it removes all breaklines in all cells.
+---------------------------------------------+
| CURRENT SCRIPT RESULT |
+---------------------------------------------+
| cell1_text1cell1_text2 |
+---------------------------------------------+
| cell2_text1 |
+---------------------------------------------+
| cell3_text1cell3_text2 |
+---------------------------------------------+
| cell4_text1 |
+---------------------------------------------+
| cell5_text1 |
+---------------------------------------------+
| cell6_text1cell6_text2cell6_text3cell6_text4|
+---------------------------------------------+
How can I test if row doesn't contain any other letter and delete only that row within cell?
How can I apply that macro only to currenty selected cells?
You need to locate and remove errant line feed characters (e.g. vbLF, Chr(10) or ASCII 010 dec). If the data was copied from an external source, it is possible that rogue carriage return characters (e.g. vbCR or Chr(13)) may have piggy-backed along and these should be scrubbed as well.
Sub clean_blank_lines()
Dim rw As Long
With Worksheets("Sheet3") '<~~SET THIS WORKSHEET REFERENCE PROPERLY!
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
With .Cells(rw, 1)
.Value = Replace(.Value2, Chr(13), Chr(10))
Do While Left(.Value2, 1) = Chr(10): .Value = Mid(.Value2, 2): Loop
Do While CBool(InStr(1, .Value, Chr(10) & Chr(10)))
.Value = Replace(.Value2, Chr(10) & Chr(10), Chr(10))
Loop
Do While Right(.Value2, 1) = Chr(10): .Value = Left(.Value2, Len(.Value2) - 1): Loop
End With
.Rows(rw).EntireRow.AutoFit
Next rw
End With
End Sub
A Range.AutoFit is performed on the finished cell to remove dead 'white space'.
Before After
To convert this to a macro that processes one or more selected cells, see Examples of Selection-based sub framework in How to avoid using Select in Excel VBA macros.
This will do it:
Instead of replacing the carriage returns, split on it then loop through and replace the value with only those items that have a value.
Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
Dim textArr() As String
textArr = Split(MyRange.Value, Chr(10))
MyRange.Value = ""
For i = LBound(textArr) To UBound(textArr)
If textArr(i) <> "" Then
If MyRange.Value = "" Then
MyRange.Value = textArr(i)
Else
MyRange.Value = MyRange.Value & Chr(10) & textArr(i)
End If
End If
Next i
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I would like to create a VBA macro that will auto number all cells in column 'A' to a single decimal place, if and only if they have a value in column 'B'. Every time there is a row that does not have a value in column 'B', column 'A' should re-start numbering at the next integer.
IE:
|COLUMN A | COLUMN B|
|:-------:|:-------:|
| 1.1 | TEXT |
| 1.2 | TEXT |
| 1.3 | TEXT |
| 1.4 | TEXT |
| 1.5 | TEXT |
| | *NO TEXT* |
| 2.1 | TEXT |
| 2.2 | TEXT |
| 2.3 | TEXT |
| | *NO TEXT* |
| 3.1 | TEXT |
| 3.2 | TEXT |
| 3.3 | TEXT |
| 3.4 | TEXT |
I think this is pretty self-explanatory, but post up if anything confuses you:
Option Explicit
Private Sub numberCells()
Dim totalRows As Long
Dim i As Long
Dim baseNumber As Long
Dim count As Integer
totalRows = ActiveSheet.UsedRange.Rows.count
baseNumber = 1
i = 2
Do While i <= totalRows
If Range("B" & i).Value <> "" Then
count = count + 1
Range("A" & i).Value = baseNumber & "." & count
Else
baseNumber = baseNumber + 1
count = 0
End If
i = i + 1
Loop
End Sub
I like using .Areas,
Here's my version
Sub Do_It_Good()
Dim RangeArea As Range, c As Range, LstRw As Long, sh As Worksheet, Rng As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
Set Rng = .Range("B2:B" & LstRw)
y = 0
For Each RangeArea In Rng.SpecialCells(xlCellTypeConstants, 23).Areas
y = y + 1
x = 0
For Each c In RangeArea.Cells
c.Offset(, -1) = y & "." & 1 + x
x = x + 1
Next c
Next RangeArea
End With
End Sub
I am trying to remove only empty lines from cells in excel. Here is what I'm trying to accoplish:
+-----------------+ +---------------------+ +---------------------+
| EXAMPLE DATA | | EXPLANATION | | EXPECTED RESULT |
+-----------------+ +---------------------+ +---------------------+
| cell1_text1 | | cell1_text1 | | cell1_text1 |
| cell1_text2 | | cell1_text2 | | cell1_text2 |
+-----------------+ +---------------------+ +---------------------+
| | | cell2_empty_line | | cell2_text1 |
| cell2_text1 | | cell2_text1 | +---------------------+
+-----------------+ +---------------------+ | cell3_text1 |
| cell3_text1 | | cell3_text1 | | cell3_text2 |
| | | cell3_emptyline | +---------------------+
| cell3_text2 | | cell3_text2 | | cell4_text1 |
+-----------------+ +---------------------+ +---------------------+
| | | cell4_emptyline | | cell5_text1 |
| | | cell4_emptyline | +---------------------+
| cell4_text1 | | cell4_text1 | | cell6_text1 |
+-----------------+ +---------------------+ | cell6_text2 |
| cell5_text1 | | cell5_text1 | | cell6_text3 |
+-----------------+ +---------------------+ | cell6_text4 |
| cell6_text1 | | cell6_text1 | +---------------------+
| cell6_text2 | | cell6_text2 |
| cell6_text3 | | cell6_text3 |
| | | cell6_emptyline |
| cell6_text4 | | cell6_text4 |
+-----------------+ +---------------------+
I have found this script:
Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
If 0 < InStr(MyRange, Chr(10)) Then
MyRange = Replace(MyRange, Chr(10), "")
End If
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
but it doesn't give me desired result, it removes all breaklines in all cells.
+---------------------------------------------+
| CURRENT SCRIPT RESULT |
+---------------------------------------------+
| cell1_text1cell1_text2 |
+---------------------------------------------+
| cell2_text1 |
+---------------------------------------------+
| cell3_text1cell3_text2 |
+---------------------------------------------+
| cell4_text1 |
+---------------------------------------------+
| cell5_text1 |
+---------------------------------------------+
| cell6_text1cell6_text2cell6_text3cell6_text4|
+---------------------------------------------+
How can I test if row doesn't contain any other letter and delete only that row within cell?
How can I apply that macro only to currenty selected cells?
You need to locate and remove errant line feed characters (e.g. vbLF, Chr(10) or ASCII 010 dec). If the data was copied from an external source, it is possible that rogue carriage return characters (e.g. vbCR or Chr(13)) may have piggy-backed along and these should be scrubbed as well.
Sub clean_blank_lines()
Dim rw As Long
With Worksheets("Sheet3") '<~~SET THIS WORKSHEET REFERENCE PROPERLY!
For rw = 2 To .Cells(Rows.Count, 1).End(xlUp).Row
With .Cells(rw, 1)
.Value = Replace(.Value2, Chr(13), Chr(10))
Do While Left(.Value2, 1) = Chr(10): .Value = Mid(.Value2, 2): Loop
Do While CBool(InStr(1, .Value, Chr(10) & Chr(10)))
.Value = Replace(.Value2, Chr(10) & Chr(10), Chr(10))
Loop
Do While Right(.Value2, 1) = Chr(10): .Value = Left(.Value2, Len(.Value2) - 1): Loop
End With
.Rows(rw).EntireRow.AutoFit
Next rw
End With
End Sub
A Range.AutoFit is performed on the finished cell to remove dead 'white space'.
Before After
To convert this to a macro that processes one or more selected cells, see Examples of Selection-based sub framework in How to avoid using Select in Excel VBA macros.
This will do it:
Instead of replacing the carriage returns, split on it then loop through and replace the value with only those items that have a value.
Sub RemoveCarriageReturns()
Dim MyRange As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For Each MyRange In ActiveSheet.UsedRange
Dim textArr() As String
textArr = Split(MyRange.Value, Chr(10))
MyRange.Value = ""
For i = LBound(textArr) To UBound(textArr)
If textArr(i) <> "" Then
If MyRange.Value = "" Then
MyRange.Value = textArr(i)
Else
MyRange.Value = MyRange.Value & Chr(10) & textArr(i)
End If
End If
Next i
Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
I need your help! how can i make a condition that will count of cells in column E that is greater or equal than column f, if one of column is zero no count
A | B | C | D | E | F
--------+-------+-------+-------+-------+--------
A1021 | A10 | A | RX1 | 99 | 98 '-------> 1'
A1021 | A10 | A | RX1 | 0 | 98
A1021 | A10 | A | RX1 | 99 | 98
A1021 | A10 | A | RX1 | 99 | 0
A1021 | A10 | A | RX1 | 98 | 98 '------> 1'
Answer is 2
'First variant
'========================================================================
Sub test()
Dim N As Long, LastRow As Long, ocell As Range
N = 0
LastRow = Cells(Rows.Count, 5).End(xlUp).Row
For Each ocell In ActiveSheet.Range("E1:E" & LastRow)
If ocell.Value >= ocell.Offset(, 1).Value And _
ocell.Value > 0 And ocell.Offset(, 1).Value > 0 Then
N = N + 1
End If
Next
MsgBox N
End Sub
'Second variant
'========================================================================
Sub test2()
Dim v As Long
v = Evaluate("sumproduct((E:E>=F:F)*(E:E>0)*(F:F>0))")
MsgBox v
End Sub