Help VBA Code Formatting, Some code stopping at row 2501

T

TkdKidSnake

Board Regular
Joined
Nov 27, 2012
Messages
245
Office Version
  1. 365
Platform
  1. Windows
Hi all,

I'm not sure if anyone will be able to help me, I have a report that has a random amount of lines where I am using VBA code to format it in the way I need. This issue is that some of the formatting code stops at row 2501 and I am not able to see why - the code I have is below:


Code: 
Range("A4:I4").Select    With Selection.Interior
        .Pattern = xlSolid
        .Color = 10498160
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Range("I4").Select
    ActiveCell.FormulaR1C1 = "Formulate Your Questions Below"
    Range("I5").Select

If anyone can see an issue or are able to provide any help then it would be greatly appreciated.

Thanks in advance.
 

Excel Facts

Format cells as currency
Select range and press Ctrl+Shift+4 to format cells as currency. (Shift 4 is the $ sign).
Sort by date Sort by votes
Unless you are leaving out some vital VBA code, it only looks like you are formatting row 4:
Code: 
Range("A4:I4").Select
...
 
Upvote 0
Apologies all, This is what I have the formatting section, where all my formatting seems to be correct up to row 2501

Code: 
Sub DiffFormat()'
' DiffFormat Macro


'
On Error Resume Next
Application.ScreenUpdating = False ' I added This SS


    Windows("Report1.xls").Activate


    ActiveSheet.Select
    Cells.Select
    With Selection
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.ColumnWidth = 65.71
    Cells.EntireColumn.AutoFit
    Columns("C:D").Select
    Selection.Delete Shift:=xlToLeft
    Range("C1:C2").Select
    Selection.Copy
    Range("E1").Select
    ActiveSheet.Paste
    Columns("C:D").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    Columns("E:F").Select
    Selection.Delete Shift:=xlToLeft
    Columns("H:H").Select
    Selection.Delete Shift:=xlToLeft
    Columns("G:G").Select
    Selection.Copy
    Columns("H:H").Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
    Range("H4").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "Diff"
    With ActiveCell.Characters(Start:=1, Length:=4).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("C1:C2").Select
    Selection.Copy
    Range("D1").Select
    ActiveSheet.Paste
    Range("C1:C2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("D1:H1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("D2:H2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A1:B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A2:B2").Select
    Selection.NumberFormat = "[$-409]d-mmm-yy;@"
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("A1:B1").Select
    ActiveCell.FormulaR1C1 = "=R[4]C[1]"
    Range("A1:B1").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Rows("5:5").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlUp
    Range("A4").Select
    ActiveCell.FormulaR1C1 = "PO" & Chr(10) & "Number"
    With ActiveCell.Characters(Start:=1, Length:=9).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("B4").Select
    ActiveCell.FormulaR1C1 = "Item" & Chr(10) & "Number"
    With ActiveCell.Characters(Start:=1, Length:=11).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("C4").Select
    ActiveCell.FormulaR1C1 = "Order" & Chr(10) & "Qty"
    With ActiveCell.Characters(Start:=1, Length:=9).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("D4").Select
    ActiveCell.FormulaR1C1 = "Qty" & Chr(10) & "Rcvd"
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("E4").Select
    ActiveCell.FormulaR1C1 = "Open" & Chr(10) & "Qty"
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("F4").Select
    ActiveCell.FormulaR1C1 = "Prom" & Chr(10) & "Dlvry"
    With ActiveCell.Characters(Start:=1, Length:=10).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "Need" & Chr(10) & "Date"
    With ActiveCell.Characters(Start:=1, Length:=9).Font
        .Name = "Tahoma"
        .FontStyle = "Bold"
        .Size = 9
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 2
    End With
    Columns("A:G").Select
    Range("A3").Activate
    Columns("A:G").EntireColumn.AutoFit
    Columns("A:H").Select
    Columns("A:B").Select
    Selection.ColumnWidth = 25#
    Range("A3").Activate
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    Range("H5").Select
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$4"
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = ""
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&9Page &P Of &N"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.5)
        .RightMargin = Application.InchesToPoints(0.5)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(0.869790157480315)
        .HeaderMargin = Application.InchesToPoints(0.5)
        .FooterMargin = Application.InchesToPoints(0.5)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlPortrait
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 30
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.View = xlPageBreakPreview
    ActiveWindow.Zoom = 100
    With ActiveWindow
        .SplitColumn = 0
        .SplitRow = 0
    End With
    Range("C5").Select
    ActiveWindow.FreezePanes = True
     Rows("5:40000").Select
    Selection.RowHeight = 18
    Columns("A:H").Select
    Range("A3").Activate
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
    End With
    


Call dater
   
    Range("H5").Select
    ActiveWindow.SmallScroll Down:=-9
    ActiveSheet.Move Before:=Sheets(1)
    
    
'FORMATS LINES ON DIFFERENCE SHEET


Static outer, outer1, outer2, line, line1, line2


Application.ScreenUpdating = False


Application.GoTo Reference:="R65000C8"
    Selection.End(xlUp).Select
    ActiveCell.Offset(2, 0).Select


outer1 = ActiveCell.Row


outer = "a4:h" & outer1


outer2 = "a4:a" & outer1


   
    
   '**********  Thin Verticle Lines for selection  *********************
    
    
 line = "a5:a" & outer1 - 1
    
    
    Range(line).Select
      With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
       With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With


    
   line = "b5:b" & outer1 - 1
        
    Range(line).Select
  
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
    
    
    line = "c5:c" & outer1 - 1
    Range(line).Select
   
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
  
    
 line = "d5:d" & outer1 - 1
       
    Range(line).Select
   
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
   
    
line = "e5:e" & outer1 - 1
    Range(line).Select
  
    With Selection.Borders(xlEdgeRight)
       .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
      
  line = "f5:f" & outer1 - 1
    
    
    Range(line).Select
 
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
     
 line = "g5:g" & outer1 - 1
    
   
    Range(line).Select
 
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
      
 line = "h5:h" & outer1 - 1
    
   
    Range(line).Select
  
    With Selection.Borders(xlEdgeRight)
        LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
 
    
       
     '**********  Adjust Row Heights  *********************
    
    
    
    Static rower, rower1, rower2, offsetter, liner3, liner4
    
    offsetter = outer1
    
    
    line2 = "a5:A" & offsetter
    
      
    For Each rower In ActiveSheet.Range(line2)
    
    
    If rower.Value = "" Then
    
    rower.RowHeight = 6
    
        
    End If
    
    Next rower
    
   '**********  Replace Solid Black Horizontal Lines *********************
       
  
       
   For Each rower1 In ActiveSheet.Range(outer2)
   
      liner3 = rower1.Address & ":" & rower1.Offset(0, 7).Address
   
   If rower1.Value = "" Then
   


   ActiveSheet.Range(liner3).Select
  


    With Selection.Borders(xlEdgeBottom)
       .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlMedium
    End With
   
  End If
  
  Next rower1
  
  
  '**********  Replace Solid Black Horizontal Lines *********************
        
   For Each rower2 In ActiveSheet.Range(outer2)
   
      liner4 = rower2.Address & ":" & rower2.Offset(0, 7).Address
      
        
   If rower2.Value > "" And rower2.Offset(1, 0).Value > "" Then
   


   ActiveSheet.Range(liner4).Select
   
      With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlDash
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThin
    End With
   
   
  
 
  End If
  
  Next rower2
  
  
    
     '**********  Set Auto Filters *********************
    
  'Range("A4:H4").Select
    'Selection.AutoFilter
    
 '**********  Outside Thick Border Lines for selection  *********************


 Range(outer).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        '.TintAndShade = 0
        .Weight = xlThick
    End With
    
        Range("D1:H2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
    'Moves Report Header'
    
    Range("D1:D2").Select
    Selection.Copy
    Range("C1").Select
    ActiveSheet.Paste
    Range("D1:D2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("C1:F1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    Range("C2:F2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
    End With
    
 ActiveSheet.Range("a1").Select
 
Last edited:
Upvote 0
OK, that is a ton of VBA code there, and you have references to different ranges and calls to other VBA code.
So you are going to need to narrow this done for us. Please identify the first part of formatting code that is not going down far enough.
 
Upvote 0
Joe4 said:
OK, that is a ton of VBA code there, and you have references to different ranges and calls to other VBA code.
So you are going to need to narrow this done for us. Please identify the first part of formatting code that is not going down far enough.
Click to expand...


I believe it's something to do with this because when I negate it the formatting stops almost immediately.

Code: 
Application.GoTo Reference:="R65000C8"    Selection.End(xlUp).Select
    ActiveCell.Offset(2, 0).Select

I think it would be better if I could find the last populated cell in column A and then add 1 for the formatting to work, unfortunately I'm no expert on VBA so not sure how to do it
 
Last edited:
Upvote 0
Here is how you can find the last populated cell in column A

Code: 
Dim lastRow as Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
 
Upvote 0
Joe4 said:
Here is how you can find the last populated cell in column A

Code: 
Dim lastRow as Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Click to expand...

Thank you, this also worked

Code: 
Application.Goto Reference:=Worksheets("HFI").Range("A65000")
 
Upvote 0
It is not the same things. Your code goes to specific cell reference (some very large number). Mine goes to the very last cell with data in it.
The danger of going farther than you need to is it could chew up extra memory and slow your workbook down, as opposed to just formatting exactly what needs to be formatted.

Also, interesting side note. People often used numbers like 65000 or 65536, because in very old versions of Excel, 65536 was the maximum number of rows you could have. However, you can now have over 1 million rows.
 
Upvote 0
Joe4 said:
It is not the same things. Your code goes to specific cell reference (some very large number). Mine goes to the very last cell with data in it.
The danger of going farther than you need to is it could chew up extra memory and slow your workbook down, as opposed to just formatting exactly what needs to be formatted.

Also, interesting side note. People often used numbers like 65000 or 65536, because in very old versions of Excel, 65536 was the maximum number of rows you could have. However, you can now have over 1 million rows.
Click to expand...


I tried putting the code that you stated in place of what I tried and it stop / didn't work so I think I must be missing something.
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
formating question
Replies
3
Views
75
Micron
M
L
  • Locked
  • Question
Help Cleaning Up Code
Replies
2
Views
334
RoryA
RoryA
P
  • Question
Issue with button not running in spread sheet only in test mode
Replies
1
Views
188
6StringJazzer
6StringJazzer
K
  • Solved
create a button that do actions
2 3
Replies
22
Views
864
kerm007
K
J
  • Question
VBA Code to Add Rows is slowing down
Replies
5
Views
515
JayB0730
J

Forum statistics

Threads
1,215,054
Messages
6,122,895
Members
449,097
Latest member
dbomb1414

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top