Sub NBExample()
Dim i As Long
For i = 0 To 5
MsgBox (i * 2 + 0) & " to " & (i * 2 + 1)
Next
End Sub
That will show you "0 to 1" "2 to 3", etc, through "10 to 11". For I = LBound(HeadingLocation) To UBound(HeadingLocation) Step 2
Range ("A" & HeadingLocation(I) & ":A" & HeadingLocation(I+1)).Select
MsgBox Range ("A" & HeadingLocation(I) & ":A" & HeadingLocation(I+1)).Address
Next I
Range("F" & Top & ":F" & Bottom).Select
Selection.NumberFormat = "#,##0"
You could have just used:
Range("F" & Top & ":F" & Bottom).NumberFormat = "#,##0"
I'm looking through your code and am cleaning it up right now. Shouldn't take too long.Sub Macro1()
Dim Top As Long, Bottom As Long
Dim HeadingLocation() As Double, HeadingNumber As Long
Dim i As Long
Dim CLL As Range
Top = Range("StartNumber").Row + 1
Bottom = Top - 1 + Range("_datarows").Value
Range("AA1").Formula = "O" & Top
Range("B3").Formula = "=INDIRECT(AA1)"
Range("AB1").Formula = "A" & Top
Range("WeekDate").Formula = "=INDIRECT(AB1)"
Range("SumRange").Formula = "=sum(F" & Top & ":F" & Bottom & ")"
Range("H" & Top & ":H" & Bottom).Insert Shift:=xlToRight
ActiveWindow.DisplayZeros = False
Range("I" & Top & ":J" & Bottom).NumberFormat = "#,##0.00"
Range("F" & Top & ":F" & Bottom).NumberFormat = "#,##0"
Range("A1:P1").UnMerge
Columns("H").EntireColumn.Delete
Columns("P").EntireColumn.Insert
With Range("D" & Bottom + 5 & ":" & "F" & Bottom + 5)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Merge
End With
Range("B1").FormulaR1C1 = "Hook2Sisters Ltd Kill Plan"
With Range("B1:N1")
.Font.Bold = True
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Merge
End With
Range("A" & Top & ":A" & Bottom).NumberFormat = "ddd dd mmm"
Range("A" & Top - 1).FormulaR1C1 = "Date"
Range("D" & Top - 1).FormulaR1C1 = "Type"
Columns("I").ColumnWidth = 10.86
Range("M" & Top - 1).FormulaR1C1 = "COMMENTS"
Range("N" & Top - 1).ClearContents
With Range("M" & Top - 1 & ":N" & Top - 1)
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.Merge
End With
' Creat righthand Table
Range("R" & Top & ":R" & Bottom).FormulaR1C1 = "=+RC[-10]*RC[-12]"
Range("S" & Top & ":S" & Bottom).FormulaR1C1 = "=IF(RC[-12]=R14C19,RC[-11],"""")"
Range("T" & Top & ":T" & Bottom).FormulaR1C1 = "=IF(RC[-13]=R14C20,RC[-12],"""")"
Range("U" & Top & ":U" & Bottom).FormulaR1C1 = "=IF(RC[-14]=R14C21,RC[-13],"""")"
Range("V" & Top & ":V" & Bottom).FormulaR1C1 = "=IF(RC[-15]=R14C22,RC[-14],"""")"
Range("W" & Top & ":W" & Bottom).FormulaR1C1 = "=IF(RC[-16]=R14C23,RC[-18],"""")"
Range("X" & Top & ":X" & Bottom).FormulaR1C1 = "=IF(RC[-17]=R14C24,RC[-19],"""")"
Range("Y" & Top & ":Y" & Bottom).FormulaR1C1 = "=IF(RC[-18]=R14C25,RC[-20],"""")"
Range("Z" & Top & ":Z" & Bottom).FormulaR1C1 = "=IF(RC[-19]=R14C26,RC[-21],"""")"
Range("F5:F11").Delete Shift:=xlToLeft
'Aveerages
Range("S" & Top - 2 & ":Z" & Top - 2).FormulaR1C1 = _
"=IFERROR(SUM(R" & Top & "C:R" & Bottom & "C)/COUNT(R" & Top & "C:R" & Bottom & "C),"""")"
'Create Top Table
'Quantities
Range("F5:F8").FormulaR1C1 = "=SUMIF(R" & Top & "C[1]:R" & Bottom & "C[1],RC[-3],R" & Top & "C:R" & Bottom & "C)"
'Averages
Range("G5").FormulaR1C1 = "=+R[10]C[14]"
Range("G6").FormulaR1C1 = "=+R[9]C[15]"
Range("G7").FormulaR1C1 = "=+R[8]C[12]"
Range("G8").FormulaR1C1 = "=+R[7]C[13]"
Range("H5").FormulaR1C1 = "=+R[10]C[17]"
Range("H6").FormulaR1C1 = "=+R[9]C[18]"
Range("H7").FormulaR1C1 = "=+R[8]C[15]"
Range("H8").FormulaR1C1 = "=+R[7]C[16]"
Range("F10").FormulaR1C1 = "=+R[-5]C+R[-3]C"
Range("F11").FormulaR1C1 = "=+R[-5]C+R[-3]C"
'Tidy
Range("A1").ClearContents
Columns("Q").EntireColumn.Insert
Columns("Q").EntireColumn.Insert
Columns("Q").EntireColumn.Insert
Columns("Q").EntireColumn.Insert
With Range("P:P,Q1:U19").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Range("F14").ClearContents
Range("F3:F4").Delete Shift:=xlToLeft
Columns("G").ColumnWidth = 7.71
Columns("B").ColumnWidth = 17.71
Range("N18:N" & Bottom).Borders.LineStyle = xlNone
Range("F8").Font.Bold = False
'Sort
Range("A16:N" & (Cells(Rows.Count, 1).End(xlUp).Row)).Sort _
Key1:=Range("A17"), Order1:=xlAscending, DataOption1:=xlSortNormal, _
Key2:=Range("B17"), Order2:=xlAscending, DataOption2:=xlSortNormal, _
Key3:=Range("C17"), Order3:=xlAscending, DataOption3:=xlSortTextAsNumbers, _
Header:=xlYes, MatchCase:=False, SortMethod:=xlPinYin
'SubTotal
Range("E17").Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(6), Replace:=True, PageBreaks:=False, SummaryBelowData:=True
'Print Area
' Range("A" & Top & ":N" & (Range("PrintCorner").Row - 1)).Select
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintArea = "$A$1:$N$32"
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.708661417322835)
.RightMargin = Application.InchesToPoints(0.708661417322835)
.TopMargin = Application.InchesToPoints(0.748031496062992)
.BottomMargin = Application.InchesToPoints(0.748031496062992)
.HeaderMargin = Application.InchesToPoints(0.31496062992126)
.FooterMargin = Application.InchesToPoints(0.31496062992126)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlPortrait
.Draft = False
.PaperSize = xlPaperLetter
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
'Set headings
Range("P" & Top).Resize(11, 1).FormulaR1C1 = "=IF(RIGHT(RC[-15],5)=""Total"",""Total"","""")"
Range("Q" & Top).Resize(11, 1).FormulaR1C1 = _
"=IF(R[-1]C[-16]=""Date"",""Yes"",IF(RC[-16]=""Grand Total"",""No"",IF(AND(R[-1]C[-1]=""Total"",RC[-16]=R[1]C[-16]),""Yes"",""No"")))"
'loop to find and insert headings
Bottom = Range("printcorner").Row
ReDim HeadingLocation(0)
HeadingNumber = 0
For Each CLL In Range("Q" & Top & ":Q" & Bottom).Cells
If CLL.Value = "Yes" Then
If CLL.Row = Range("printcorner").Row Then Exit For
CLL.EntireRow.Insert Shift:=xlDown
'add heading text
With Intersect(CLL.EntireRow, Columns("A")).Offset(-1, 0)
.Offset(1, 0).Copy Destination:=.Cells(1, 1)
.NumberFormat = "dddd dd mmmm"
With .Resize(1, 4)
.Merge
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
With .Font
.Bold = True
.Name = "Calibri"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End With
ReDim Preserve HeadingLocation(HeadingNumber)
HeadingLocation(HeadingNumber) = .Row
HeadingNumber = HeadingNumber + 1
End With
End If
Next
For i = LBound(HeadingLocation) To UBound(HeadingLocation) Step 2
With Range("A" & HeadingLocation(i) & ":A" & HeadingLocation(i + 1) - 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Next i
End Sub
Give it a try, and let me know how it went! HeadingNumber = HeadingNumber + 1
End With
Set CLL = CLL.Offset(1, 0)
End If
Next
If you ever did have two "Yes" cells in a row, that would skip the second one. A sample book would be best though so I could figure out exactly why.
'loop to find and insert headings
Bottom = Range("printcorner").Row
ReDim HeadingLocation(0)
HeadingNumber = 0
Dim bRow As Range
Set bRow = Range("Q" & Bottom)
Set CLL = Range("Q" & Top)
Do
If CLL.Value = "Yes" Then
If CLL.Row = Range("printcorner").Row Then Exit Do
CLL.EntireRow.Insert Shift:=xlDown
'add heading text
With Intersect(CLL.EntireRow, Columns("A")).Offset(-1, 0)
.Offset(1, 0).Copy Destination:=.Cells(1, 1)
.NumberFormat = "dddd dd mmmm"
With .Resize(1, 4)
.Merge
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = True
With .Font
.Bold = True
.Name = "Calibri"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ThemeColor = xlThemeColorLight1
.TintAndShade = 0
.ThemeFont = xlThemeFontMinor
End With
End With
ReDim Preserve HeadingLocation(HeadingNumber)
HeadingLocation(HeadingNumber) = .Row
HeadingNumber = HeadingNumber + 1
End With
End If
If Intersect(CLL.EntireRow, Columns("A")).Value = "Grand Total" Then
Set bRow = CLL.Offset(-1, 0)
Exit Do
End If
If CLL.Address = bRow.Address Then Exit Do
Set CLL = CLL.Offset(1, 0)
Loop
For i = LBound(HeadingLocation) To UBound(HeadingLocation) Step 2
If i = UBound(HeadingLocation) Then
With Range("A" & HeadingLocation(i) & ":A" & bRow.Row).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Else
With Range("A" & HeadingLocation(i) & ":A" & HeadingLocation(i + 1) - 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End If
Next i
End Sub
Should do the trick! For i = LBound(HeadingLocation) To UBound(HeadingLocation)
If i = UBound(HeadingLocation) Then
With Range("A" & HeadingLocation(i) + 1 & ":A" & bRow.Row).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
Else
With Range("A" & HeadingLocation(i) + 1 & ":A" & HeadingLocation(i + 1) - 1).Font
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
End With
End If
Next i
EDIT: added +1 after headinglocation(i)
Range("M" & Top & ":M" & Range("printcorner").Row).Replace What:="*", Replacement:="Salmonella"
Bottom = Cells(Rows.Count, 1).End(xlUp).Row
ActiveWorkbook.ActiveSheet.Sort.SortFields.Clear
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("A17:A" & Bottom) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("B17:B" & Bottom) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
ActiveWorkbook.ActiveSheet.Sort.SortFields.Add Key:=Range("C17:C" & Bottom) _
, SortOn:=xlSortTextAsNumbers, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.ActiveSheet.Sort
.SetRange Range("A17:N" & Bottom)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
If you are experiencing a similar issue, please ask a related question
Title | # Comments | Views | Activity |
---|---|---|---|
How to have a separate survey result in SharePoint 2013? | 1 | 114 | |
Internet Explorer View Settings Question | 15 | 111 | |
Excel object stays open | 19 | 76 | |
VBA change replacement list from code to excel sheet list | 2 | 50 |
Join the community of 500,000 technology professionals and ask your questions.