jski21
Board Regular
- Joined
- Jan 2, 2019
- Messages
- 155
- Office Version
- 2016
- Platform
- Windows
Good day all,
I'm using the following code to tighten up a data extract. Works ok up to the point where I'm trying to insert a tab from another workbook that is on my laptop. I--believe it or not--get a "Division by zero" error. Here's the code (trouble spot in red). This is my first attempt to pull in a tab from another file. Thanks everyone. ---jski---
Sub FormatGrantDrws()
'
' Format Downloaded Report
Dim lngLastRow As Long
Dim WB As Workbook
Dim SourceWB As Workbook
Dim WS As Worksheet
Dim ASheet As Worksheet
'Turns off screenupdating and events:
Application.ScreenUpdating = False
Application.EnableEvents = False
'Delete the first blank row and first blank column. Change font to Calibri 10.
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
'Change Zoom to 90%, format numbers in Columns E thru J, and convert all data to a Table
ActiveWindow.Zoom = 90
Columns("H:H").Select
Selection.NumberFormat = "#,##0.00"
ActiveSheet.ListObjects.Add(xlSrcRange, Range([A1].End(xlDown), [A1].End(xlToRight)), , xlYes).Name = _
"Table1"
Range("Table1[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13"
'Autofit all the Columns
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Range("A:K").Select
ActiveWindow.SmallScroll Down:=0
'Freeze pane the first row
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Range("F:F").NumberFormat = "General"
Range("G1").EntireColumn.Insert
Range("G1").Select
ActiveCell.FormulaR1C1 = "Program Name"
'Combine text in Columns D and E to Produce Major Program Number
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row
Range("F2").Formula = "=D2&E2"
Range("F2").Copy Range("F3:F" & lngLastRow)
'Copy A Range of Data
Worksheets("Grant Draws").Range("F:F").Copy
'PasteSpecial Values Only
Range("F2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Clear Clipboard (removes "marching ants" around your original data set)
Application.CutCopyMode = False
Columns("F:F").Select
Selection.NumberFormat = "###0"
Cells.Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort.SortFields. _
Add Key:=Range("Table1[[#All],[Jrnl Trans. Record Date]]"), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sets the variables:
Set WB = ActiveWorkbook
Set ASheet = ActiveSheet
THIS LINE > Set SourceWB = Workbooks.Open(C \ Users \ JKucharski \ Desktop & "\DateTable.xls")
'Copies each sheet of the SourceWB to the beginning of original WB:
For Each WS In SourceWB.Worksheets
WS.Copy before:=WB.Sheets(WB.Sheets.Count)
Next WS
SourceWB.Close savechanges:=False
Set WS = Nothing
Set SourceWB = Nothing
WB.Activate
ASheet.Select
Set ASheet = Nothing
Set WB = Nothing
Application.EnableEvents = True
'Set Precision as Dispalyed (remove (0.00) Values
ActiveWorkbook.PrecisionAsDisplayed = True
End Sub
I'm using the following code to tighten up a data extract. Works ok up to the point where I'm trying to insert a tab from another workbook that is on my laptop. I--believe it or not--get a "Division by zero" error. Here's the code (trouble spot in red). This is my first attempt to pull in a tab from another file. Thanks everyone. ---jski---
Sub FormatGrantDrws()
'
' Format Downloaded Report
Dim lngLastRow As Long
Dim WB As Workbook
Dim SourceWB As Workbook
Dim WS As Worksheet
Dim ASheet As Worksheet
'Turns off screenupdating and events:
Application.ScreenUpdating = False
Application.EnableEvents = False
'Delete the first blank row and first blank column. Change font to Calibri 10.
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Cells.Select
With Selection.Font
.Name = "Calibri"
.Size = 10
End With
'Change Zoom to 90%, format numbers in Columns E thru J, and convert all data to a Table
ActiveWindow.Zoom = 90
Columns("H:H").Select
Selection.NumberFormat = "#,##0.00"
ActiveSheet.ListObjects.Add(xlSrcRange, Range([A1].End(xlDown), [A1].End(xlToRight)), , xlYes).Name = _
"Table1"
Range("Table1[#All]").Select
ActiveSheet.ListObjects("Table1").TableStyle = "TableStyleLight13"
'Autofit all the Columns
Columns("A:K").Select
Columns("A:K").EntireColumn.AutoFit
Range("A:K").Select
ActiveWindow.SmallScroll Down:=0
'Freeze pane the first row
With ActiveWindow
.SplitColumn = 0
.SplitRow = 1
End With
ActiveWindow.FreezePanes = True
Range("F:F").NumberFormat = "General"
Range("G1").EntireColumn.Insert
Range("G1").Select
ActiveCell.FormulaR1C1 = "Program Name"
'Combine text in Columns D and E to Produce Major Program Number
lngLastRow = Cells(Rows.Count, "F").End(xlUp).Row
Range("F2").Formula = "=D2&E2"
Range("F2").Copy Range("F3:F" & lngLastRow)
'Copy A Range of Data
Worksheets("Grant Draws").Range("F:F").Copy
'PasteSpecial Values Only
Range("F2").Select
Range(ActiveCell, ActiveCell.End(xlDown)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'Clear Clipboard (removes "marching ants" around your original data set)
Application.CutCopyMode = False
Columns("F:F").Select
Selection.NumberFormat = "###0"
Cells.Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.EntireRow.AutoFit
ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort.SortFields. _
Clear
ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort.SortFields. _
Add Key:=Range("Table1[[#All],[Jrnl Trans. Record Date]]"), SortOn:= _
xlSortOnValues, Order:=xlAscending, DataOption:=xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Grant Draws").ListObjects("Table1").Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Sets the variables:
Set WB = ActiveWorkbook
Set ASheet = ActiveSheet
THIS LINE > Set SourceWB = Workbooks.Open(C \ Users \ JKucharski \ Desktop & "\DateTable.xls")
'Copies each sheet of the SourceWB to the beginning of original WB:
For Each WS In SourceWB.Worksheets
WS.Copy before:=WB.Sheets(WB.Sheets.Count)
Next WS
SourceWB.Close savechanges:=False
Set WS = Nothing
Set SourceWB = Nothing
WB.Activate
ASheet.Select
Set ASheet = Nothing
Set WB = Nothing
Application.EnableEvents = True
'Set Precision as Dispalyed (remove (0.00) Values
ActiveWorkbook.PrecisionAsDisplayed = True
End Sub