Having trouble coding a macro in vba to exclude certain columns from being included in a chart. I want to exclude Column F from being included. Here is my code from a recoreded macro that I tweaked a bit:
Sub Macro4()
Dim ws As Worksheet
Dim wb As Workbook
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
ActiveSheet.Shapes.AddChart2(251, xlBarClustered).Select
ActiveChart.SetSourceData Source:=ws.Range("E" & ActiveCell.Row & ":F" & ActiveCell.Row & ":G" & ActiveCell.Row & ":H" & ActiveCell.Row)
ActiveChart.FullSeriesCollection(1).XValues = "=Sheet1!$E$9:$H$9"
ActiveChart.SetElement (msoElementDataLabelOutSideEnd)
ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesNone)
ActiveChart.Axes(xlValue).MajorGridlines.Format.Line.Visible = msoFalse
ActiveChart.FullSeriesCollection(1).DataLabels.ShowCategoryName = False
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Analysis for " & ws.Range("C" & ActiveCell.Row)
ActiveChart.HasAxis(xlValue) = False
ActiveChart.HasLegend = False
End With
End Sub
Try the following, you use "," to delimit non-consecutive ranges:
ActiveChart.SetSourceData Source:=ws.Range("Sheet1!$E$" & ActiveCell.Row & ",Sheet1!$G$" & ActiveCell.Row & ",Sheet1!$H$" & ActiveCell.Row)
ActiveChart.FullSeriesCollection(1).XValues = "=Sheet1!$E$9,Sheet1!$G$9,Sheet1!$H$9"
This should exclude F from your chart.
Edit:
To create your chart only using data from the active row, you can try:
Sub Macro4()
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
ws.Activate
Dim MyRange1 As Range: Set MyRange1 = Range("E" & ActiveCell.Row)
Dim MyRange2 As Range: Set MyRange2 = Range(Cells(ActiveCell.Row, "G"), Cells(ActiveCell.Row, "H"))
Dim MyChartRange As Range: Set MyChartRange = Union(MyRange1, MyRange2)
ActiveSheet.Shapes.AddChart2(251, xlBarClustered).Select
ActiveChart.SetSourceData Source:=MyChartRange
ActiveChart.FullSeriesCollection(1).XValues = "=Sheet1!$E$9:$H$9"
ActiveChart.SetElement (msoElementDataLabelOutSideEnd)
ActiveChart.SetElement (msoElementPrimaryCategoryGridLinesNone)
ActiveChart.Axes(xlValue).MajorGridlines.Format.Line.Visible = msoFalse
ActiveChart.FullSeriesCollection(1).DataLabels.ShowCategoryName = False
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "Analysis for " & ws.Range("C" & ActiveCell.Row)
ActiveChart.HasAxis(xlValue) = False
ActiveChart.HasLegend = False
End With
End Sub
Related
I am new to vba and have written some code to delete specific data and refresh 2 pivot tables. It works fine when I step through each sub but when I add the module to a button so everything is run with the press of the button all the data is deleted.
Below is the code I have written( might be a bit cumbersome but I am still learning). I Hope someone can help me.
Sub Deleteheader()
ActiveWindow.FreezePanes = False
Rows("1:4").Select
Selection.Delete Shift:=xlUp
End Sub
Sub DeleteColumns()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
ColTotal = wsAvlRpt.UsedRange.Column + wsAvlRpt.UsedRange.Columns.Count - 1
LastCol = Split(Cells(1, ColTotal).Address, "$")(1)
For i = 1 To ColTotal
ColumnName = wsAvlRpt.Cells(1, i)
Values = wsSetUp.Range("A" & Rows.Count).End(xlUp).Row
cntColName = Application.CountIf(wsSetUp.Range("A2:A" & Values), ColumnName)
If cntColName = 0 Then
wsAvlRpt.Columns(i).EntireColumn.Delete
i = i - 1
ColTotal = ColTotal - 1
End If
If ColTotal <= i Then
Exit For
End If
Next i
wsAvlRpt.Columns(7).EntireColumn.Insert
wsAvlRpt.Range("G1").Value = "Item Desc"
Columns("G:G").Select
Selection.NumberFormat = "General"
End Sub
Public Sub DeleteStatus()
Dim wsAvlRpt As Worksheet
Dim lngLastRow As Long
Dim rngAvl As Range
Set wsAvlRpt = ThisWorkbook.Worksheets("AvlRpt")
With wsAvlRpt
lngLastRow = .Range("C" & .Rows.Count).End(xlUp).Row
Set rngAvl = .Range("A2:J" & lngLastRow)
End With
Application.DisplayAlerts = False
With rngAvl
.AutoFilter field:=8, _
Criteria1:="Ongoing", _
Operator:=xlOr, _
Criteria2:="P.Label"
.Offset(0).Resize(.Rows.Count).SpecialCells(xlCellTypeVisible).Rows.Delete
End With
Application.DisplayAlerts = True
With wsAvlRpt
.AutoFilterMode = False
If .FilterMode = True Then
.ShowAllData
End If
End With
End Sub
Sub DeleteZeroInventory()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Set wsSetUp = ActiveWorkbook.Worksheets("SetUp")
cntZeroInventory = Application.CountIf(wsAvlRpt.Range("I:I"), "<=0.0")
If cntZeroInventory > 0 Then
Total = wsAvlRpt.Cells(Rows.Count, "A").End(xlUp).Row
wsAvlRpt.Range("$A1:J" & Total).AutoFilter field:=9, Criteria1:="<=0.0", _
Operator:=xlFilterValues
wsAvlRpt.Range("A2:J" & Total).Select
Selection.SpecialCells(xlCellTypeVisible).EntireRow.Delete
wsAvlRpt.ShowAllData
wsAvlRpt.Columns(10).EntireColumn.Insert
wsAvlRpt.Range("J1").Value = "Available Eaches"
End If
End Sub
Sub CalcEaches()
Dim LastRow As Long
Sheets("AvlRpt").Activate
LastRow = Range("I65536").End(xlUp).Row
Range("I2:I" & LastRow).Select
Selection.Offset(0, 1).Select
Selection.FormulaR1C1 = "= RC[-1] *12"
Selection = Selection.Value
End Sub
Sub AddItemDesc()
With Sheets("AvlRpt")
.Range("G2:G" & .Range("C" & Rows.Count).End(xlUp).Row).Formula = _
"=IF(ISERROR(VLOOKUP(C2,SetUp!I:J,2,FALSE)),0,VLOOKUP(C2,SetUp!I:J,2,FALSE))"
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value = _
.Range("G2:G" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
End Sub
Sub DeleteStyles()
Dim wsAvlRpt As Worksheet, wsSetUp As Worksheet
Set wsAvlRpt = ActiveWorkbook.Worksheets("AvlRpt")
Dim AvlRpt As Range
Set AvlRpt = wsAvlRpt.Range("A1", Range("A1").End(xlDown).End(xlToRight))
AvlRpt.AutoFilter field:=3, Criteria1:=Array("7A37", "8A37", "CO07", "CO81"), _
Operator:=xlFilterValues
AvlRpt.CurrentRegion.Offset(1, 0).Select
With Selection
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
If wsAvlRpt.FilterMode Then
wsAvlRpt.ShowAllData
End If
End With
End Sub
Sub ClearContents()
Worksheets("CloseoutData").Range("A2:J2000").Clear
End Sub
Sub CopyDeleteAvlRpt()
Application.DisplayAlerts = False
Sheets("AvlRpt").Range("A2:J2000").Copy _
Destination:=Sheets("CloseoutData").Range("A2:J2000")
Sheets("AvlRpt").Delete
Application.DisplayAlerts = True
End Sub
Sub RefreshPivots()
ThisWorkbook.RefreshAll
End Sub
Sub PivotCopyAdults()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Adults")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Adults"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub
Sub PivotCopyYouthLadies()
Dim pt As PivotTable, lRow As Long
Dim oWS_Copy As Worksheet, oWS_Paste As Worksheet
Set oWS_Copy = Sheets("Youth&Ladies")
Set oWS_Paste = Sheets.Add
ActiveSheet.Name = "CloseOuts Youth & Ladies"
For Each pt In oWS_Copy.PivotTables
pt.TableRange2.Copy
lRow = oWS_Paste.Cells(Rows.Count, 1).End(xlUp).Row + 1
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteValues
oWS_Paste.Range("A" & lRow).PasteSpecial Paste:=xlPasteFormats
Next pt
oWS_Paste.Cells.Columns.AutoFit
End Sub
I have created a macro, which runs fine but, for no reason I can explain, takes so long to finish. I have tried running the macro line to line and cannot figure out which part of the process takes so long. I can only imagine that it is the part where I delete rows based on backround color. I have built several macros with similar lines of code and the performance was way better.
Sub Pharma_Stock_Report()
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim lastrow1 As Long
Dim lastrow2 As Long
Dim lastrow3 As Long
Dim cell As Range
Dim DeleteRange As Range
spath1 = Application.ThisWorkbook.Path & "\Pharma replenishment.xlsm"
spath2 = Application.ThisWorkbook.Path & "\NOT OK.xlsx"
Workbooks.Open spath1
Workbooks.Open spath2
Set ws1 = Workbooks("Pharma Stock Report.xlsm").Worksheets("Pharma Stock Report")
Set ws2 = Workbooks("Pharma replenishment.xlsm").Worksheets("Replenishment")
Set ws3 = Workbooks("NOT OK.xlsx").Worksheets("Sheet1")
ws1.Cells.Clear
lastrow1 = ws2.Range("A" & Rows.Count).End(xlUp).Row
ws2.Range("A4:G" & lastrow1).Copy
With ws1.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
Application.CutCopyMode = False
Workbooks("Pharma replenishment.xlsm").Close
lastrow2 = ws1.Range("A" & Rows.Count).End(xlUp).Row
For Each cell In ws1.Range("D2:D" & lastrow2)
If Not cell.Interior.ColorIndex = 2 Or cell.Interior.ColorIndex = -4142 Then
If DeleteRange Is Nothing Then
Set DeleteRange = cell
Else
Set DeleteRange = Union(DeleteRange, cell)
End If
End If
Next cell
If Not DeleteRange Is Nothing Then DeleteRange.EntireRow.Delete
ws3.Range("H1:J1").Copy
With ws1.Range("H1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
End With
lastrow3 = ws1.Range("D" & Rows.Count).End(xlUp).Row
ws1.Range("H2:H" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:H,3,FALSE),"""")"
With Range("H2:H" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
ws1.Range("I2:I" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:I,4,FALSE),"""")"
With Range("I2:I" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
ws1.Range("J2:J" & lastrow3).Formula = "=IFERROR(VLOOKUP(C2,'[NOT OK.xlsx]Sheet1'!F:J,5,FALSE),"""")"
With Range("J2:J" & lastrow3)
.Value = .Value
.NumberFormat = "dd/mm/yyyy"
End With
Application.CutCopyMode = False
Workbooks("NOT OK.xlsx").Close
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
I am working on macro that will copy the data from report to multiple worksheets. The macro works fine but I am struggling with one little thing. I would like to copy not only B9:J range but also N8:N however when I put ("B9:J" & "N9:N" & Lastrow) the macro copies everything from column B to N but I would like to skip columns K, L, M. I tried to put Range("B2", "N2") and Range("B2" & "N2") in Copy tgt.Range("B2").End(xlDown).Offset(1) but it doesn't work.
Sub report_template()
Const fromFile = "c:\Users\" & Environ("username") & "\Desktop\Report.xls"
Dim srcBook As Workbook
Set srcBook = Application.Workbooks.Open(fromFile, _
UpdateLinks:=False)
Application.ScreenUpdating = False
srcBook.Sheets("Report Page").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ActiveSheet.Name = "report"
srcBook.Close False
Dim src As Worksheet
Dim tgt As Worksheet
Dim filterRange As Range
Dim filterRange2 As Range
Dim filterRange3 As Range
Dim filterRange4 As Range
Dim copyRange As Range
Dim Lastrow As Long
Dim tgt2 As Worksheet
Set src = ThisWorkbook.Sheets("report")
Set tgt = ThisWorkbook.Sheets("1")
Set tgt2 = ThisWorkbook.Sheets("2")
Set tgt3 = ThisWorkbook.Sheets("3")
Set tgt4 = ThisWorkbook.Sheets("4")
src.AutoFilterMode = False
Lastrow = src.Range("B" & src.rows.Count).End(xlUp).Row
Set filterRange = src.Range("A8:J" & Lastrow)
Set copyRange = src.Range("B9:J" & Lastrow)
filterRange.AutoFilter Field:=1, Criteria1:="EN > 1"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt.Range("B2").End(xlDown).Offset(1)
Set filterRange2 = src.Range("A8:J" & Lastrow)
filterRange2.AutoFilter Field:=1, Criteria1:="EN > 2"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt2.Range("B2").End(xlDown).Offset(1)
Set filterRange3 = src.Range("A8:J" & Lastrow)
filterRange3.AutoFilter Field:=1, Criteria1:="EN > 3"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt3.Range("B2").End(xlDown).Offset(1)
Set filterRange4 = src.Range("A8:J" & Lastrow)
filterRange4.AutoFilter Field:=1, Criteria1:="EN > 4"
copyRange.SpecialCells(xlCellTypeVisible).Copy tgt4.Range("B2").End(xlDown).Offset(1)
Application.DisplayAlerts = False
Worksheets("report").Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = False
End Sub
This will construct multiarea range:
Range("B9:J" & Lastrow & "," & "N9:N" & Lastrow)
I have a macro program that parses through a worksheet and creates new work book based on one particular column. In my case new workbooks will be created based on column 3. Also I have written a call function to protect the individual workbooks with a password. Only few columns are editable and the rest of the columns are read only. Now I want to apply auto filter and sort function so that the user can search information based on their need and enter values in the editable cells. However when we protect the sheet autofilter doesn't work. Can you help in adding autofilter function on a protected sheet for each individual workbooks.
Sample code shown for reference.
Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 3
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:Z1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
'===================================================================
'~~Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Workbooks.Add
ActiveWorkbook.Sheets.Add(0).Name = myarr(i) & ""
'===================================================================
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
'==========================================================================
'~~ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'~~Sheets(myarr(i) & "").Columns.AutoFit
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy ActiveWorkbook.Sheets("Sheet1").Range("A1")
'mainworkBook.Sheets(1).Range("T2:T1000").Formula = "=SUM(Q2:S2)"
ActiveWorkbook.SaveAs "C:\Macros\Split_Files\" & myarr(i) & ".xlsx"
'=========================================================================
ActiveWorkbook.Close
Next
ws.AutoFilterMode = False
ws.Activate
Call ProtectAll
End Sub
Sub ProtectAll()
Dim wBk As Workbook
Dim sFileSpec As String
Dim sPathSpec As String
Dim sFoundFile As String
Dim mainworkBook As Workbook
Dim ws1 As Worksheet
Dim LastRow As Long
sPathSpec = "C:\Macros\Split_Files\"
sFileSpec = "*.xlsx"
sFoundFile = Dir(sPathSpec & sFileSpec)
Do While sFoundFile <> ""
Set wBk = Workbooks.Open(sPathSpec & sFoundFile)
With wBk
Set mainworkBook = wBk
'mainworkBook.Sheets(1).Unprotect passowrd = "abc"
Set ws1 = mainworkBook.Sheets(1)
LastRow = ws1.Cells(ws1.Rows.Count, "U").End(xlUp).Row
mainworkBook.Sheets(1).Range("U2:U" & LastRow).Formula = "=SUM(R2:T2)"
'mainworkBook.Sheets(1).Range("A:Z").Locked = True
'mainworkBook.Sheets(1).Range("A1:Z1").Locked = False
'mainworkBook.Sheets(1).Range("Q:S").Locked = False
'mainworkBook.Sheets(1).Range("U:U").Locked = False
'mainworkBook.Sheets(1).Range("W:X").Locked = False
mainworkBook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit
'mainworkBook.Sheets(1).Protect passowrd = "abc"
'mainworkBook.Sheets(1).Protect passowrd:="abc", userinterfaceonly:=True
'mainworkBook.Sheets(1).EnableOutlining = True
'mainworkBook.Sheets(1).EnableAutoFilter = True
'mainworkBook.Sheets(1).EnableSelection = xlUnlockedCells
Worksheets(2).Visible = xlSheetHidden
Worksheets(3).Visible = xlSheetHidden
Application.DisplayAlerts = False
wBk.SaveAs Filename:=.FullName
Application.DisplayAlerts = True
End With
Set wBk = Nothing
Workbooks(sFoundFile).Close False
sFoundFile = Dir
Loop
End Sub
Regards,
Linu
In order to sort in a protected sheet you would have to unprotect it and protect it again afterwards.
But you could use the filter function even when the sheet is protected, just not sort.
Here are two little functions I used for on of my projects:
Function protect_sheet(sheetname As String)
If Sheets(sheetname).ProtectContents = False Then
Sheets(sheetname).Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True
End If
End Function
Function unprotect_sheet(sheetname As String)
If Sheets(sheetname).ProtectContents = True Then
Sheets(sheetname).Unprotect Password:=Password
End If
End Function
I need to get every odd row in a range (in my case, the range is RngList) using VBA in Excel.
Here is my code, it comes out a blank chart:
Sub Chart()
Dim myData As String, sh As String
Dim LastRow As Long
Dim Rng As Range
Dim RngList As Range
With ActiveSheet
LastRow = .Range("C" & .Rows.count).End(xlUp).Row - 2
Set RngList = .Range("D1:U" & LastRow & ", C2:C" & LastRow)
Set Rng = RngList(1)
For CurRow = 3 To LastRow - 1 Step 2
Set Rng = Union(Rng, RngList(CurRow))
Next CurRow
End With
sh = ActiveSheet.Name
Charts.Add
ActiveChart.ChartType = xlLine
ActiveChart.SetSourceData Source:=Rng, PlotBy:=xlColumns
ActiveChart.Location Where:=xlLocationAsObject, Name:=sh
ActiveChart.SeriesCollection(1).XValues = Range("C2:C" & LastRow)
With ActiveChart
.HasTitle = True
.ChartTitle.Characters.Text = "PVC MIXER"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "BATCH NUMBER"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "WEIGHT"
End With
ActiveChart.ChartArea.Select
Set Rng = Nothing
Set RngList = Nothing
End Sub
Try this out which worked for me.
Sub marine()
Dim sh As Worksheet: Set sh = ActiveSheet
Dim lr As Long, RngList As Range, rng As Range
With sh
lr = .Range("C" & .Rows.Count).End(xlUp).Row - 2
Set RngList = .Range("C2:C" & lr)
Set rng = RngList(1).Resize(, 19) 'resize until Column U
Dim c As Range
For Each c In RngList
If c.Row Mod 2 = 1 Then
Set rng = Union(rng, c.Resize(, 19))
End If
Next
Dim ch As Chart
Set ch = .Shapes.AddChart2(, xlLine).Chart
With ch
.SetSourceData rng
.HasTitle = True
.ChartTitle.Characters.Text = "PVC MIXER"
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "BATCH NUMBER"
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "WEIGHT"
End With
End With
End Sub
I think you need to allow for a null range to begin with:
With ActiveSheet
LastRow = .Range("C" & .Rows.Count).End(xlUp).Row - 2
Set RngList = .Range("D1:U" & LastRow & ", C2:C" & LastRow)
Set rng = RngList(1)
For CurRow = 3 To LastRow - 1 Step 2
If Not rng Is Nothing Then
Set rng = Union(rng, RngList(CurRow))
Else
Set rng = RngList(CurRow)
End If
Next CurRow
End With