ddwestenskow
New Member
- Joined
- Jul 11, 2008
- Messages
- 10
Hi Everyone,
This is my first real VBA macro project and I am running into a few problems. The macro works great with small amounts of data, but when I am importing 1,000 rows into a data base of around 6-12,000 excel cant handle it and the program freezes.
Basically the macro...
1. Imports data from various spread sheets (anywhere from 10-45, anywhere from 500-1500 rows of total data)
-The data goes from column A-AJ
2. It adds a date stamp and highlights new entries
3. It deletes entries over 6 months old and also deletes duplicate entries
4. arranges data by date, newest first
5. There are also 9 pivot tables (1 actual table copied and pasted 8 times into different sheets)
6. It refreshes the pivot tables
7. It does some basic formating on the tables and saves the changes
I am not sure if I am just trying to accomplish to much with one macro, or if it is just very inefficiently written (probably both), or if the processing power of my PC is to blame. I have added a second method of deleting duplicates thinking that this was the source of the problem, but it doesnt seem to make it any slower or faster.
Here is the code. If this is not readible enough I can attach a file, but I will have to work on an example that I am able to post. Please let me know, any insight would be greatly appreciated.
Thanks in advance for the help,
Dawson
This is my first real VBA macro project and I am running into a few problems. The macro works great with small amounts of data, but when I am importing 1,000 rows into a data base of around 6-12,000 excel cant handle it and the program freezes.
Basically the macro...
1. Imports data from various spread sheets (anywhere from 10-45, anywhere from 500-1500 rows of total data)
-The data goes from column A-AJ
2. It adds a date stamp and highlights new entries
3. It deletes entries over 6 months old and also deletes duplicate entries
4. arranges data by date, newest first
5. There are also 9 pivot tables (1 actual table copied and pasted 8 times into different sheets)
6. It refreshes the pivot tables
7. It does some basic formating on the tables and saves the changes
I am not sure if I am just trying to accomplish to much with one macro, or if it is just very inefficiently written (probably both), or if the processing power of my PC is to blame. I have added a second method of deleting duplicates thinking that this was the source of the problem, but it doesnt seem to make it any slower or faster.
Rich (BB code):
Private Declare Function SetCurrentDirectoryA Lib _
"kernel32" (ByVal lpPathName As String) As Long
Sub ChDirNet(szPath As String)
SetCurrentDirectoryA szPath
End Sub
Sub Collect_data_from_selected_files()
'These Collect the data into the Pivot Data work sheet
Dim MyPath As String
Dim SourceRcount As Long, Fnum As Long
Dim mybook As Workbook, BaseWks As Worksheet
Dim sourceRange As Range, destrange As Range
Dim rnum As Long, CalcMode As Long
Dim SaveDriveDir As String
Dim FName As Variant
Dim FirstCell As String
Dim R As Long
'These delete the duplicate rows
Dim cRow As Long 'Changed from Integer to Long b/c of runtime 6 error
Dim cRow2 As Long 'Changed from Integer to Long b/c of runtime 6 error
Dim cCol As Long 'Changed from Integer to Long b/c of runtime 6 error
Dim foundDuplicate As Boolean
Dim rngPasteTo As Range 'new
Dim wksPasteTo As Worksheet
'Delete entried older than 6 months
Const cColumnAJ = 36
Dim myRow As Integer
Dim ws As Worksheet
Dim vCellValue As Variant
Dim myRowStr As String
Dim myDate As Date
'Unhide Data Sheet
'Sheets("Data Sheet").Visible = True
'Unlock sheet and change old data to no highlighting
Sheets("Pivot Data").Select
ActiveSheet.Unprotect
Windows("WorkSheet.xls").Activate
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Interior.ColorIndex = xlNone
Windows("WorkSheet.xls").Activate
Worksheets("Pivot Data").Activate
Range("A2").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Interior.ColorIndex = xlNone
'Delete entries older than 6 months
'enumerate worksheets collection
For Each ws In Worksheets
'select worksheet
Sheets("Pivot Data").Select
'traverse cells, from last used cell to first one
For myRow = ws.UsedRange.Rows.Count To 1 Step -1
'get cell value
vCellValue = ws.Cells(myRow, cColumnAJ)
'is value a date?
If IsDate(vCellValue) Then
'compare date, delete row
'If vCellValue <= myDate Then ws.Rows(myRow).Delete
If vCellValue < DateSerial(Year(Now()), Month(Now()) - 6, Day(Now()) + 1) Then
ws.Rows(myRow).Delete
End If
End If
Next myRow
Next ws
'Select the files that you want to add to the data base
'Change ScreenUpdating, Calculation and EnableEvents
Beep
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
SaveDriveDir = CurDir
ChDirNet "C:\Documents and Settings\Desktop"
FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
MultiSelect:=True)
If IsArray(FName) Then
'Add a new workbook with one sheet
Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
rnum = 1
'Loop through all files in the array(myFiles)
For Fnum = LBound(FName) To UBound(FName)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(FName(Fnum))
On Error GoTo 0
If Not mybook Is Nothing Then
On Error Resume Next
With mybook.Worksheets(1)
FirstCell = "A2"
Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells))
'Test if the row of the last cell >= then the row of the FirstCell
If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then
Set sourceRange = Nothing
End If
End With
If Err.Number > 0 Then
Err.Clear
Set sourceRange = Nothing
Else
'if SourceRange use all columns then skip this file
If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
Set sourceRange = Nothing
End If
End If
On Error GoTo 0
If Not sourceRange Is Nothing Then
SourceRcount = sourceRange.Rows.Count
If rnum + SourceRcount >= BaseWks.Rows.Count Then
MsgBox "Sorry there are not enough rows in the sheet"
BaseWks.Columns.AutoFit
mybook.Close savechanges:=False
GoTo ExitTheSub
Else
'Copy the file name in column A
With sourceRange
BaseWks.Cells(rnum, "A"). _
Resize(.Rows.Count).Value = FName(Fnum)
End With
'Set the destrange
Set destrange = BaseWks.Range("B" & rnum)
'we copy the values from the sourceRange to the destrange
With sourceRange
Set destrange = destrange. _
Resize(.Rows.Count, .Columns.Count)
End With
destrange.Value = sourceRange.Value
rnum = rnum + SourceRcount
End If
End If
mybook.Close savechanges:=False
End If
Next Fnum
BaseWks.Columns.AutoFit
End If
ExitTheSub:
'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
ChDirNet SaveDriveDir
'Delete extra column and paste in the "WorkSheet" wrkbook, "data sheet" wrksheet
Windows("Sheet1").Activate
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
'High light in Red and Cut
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
With Selection.Interior
.ColorIndex = 3
.Pattern = xlSolid
End With
Selection.Cut
'Select the sheet and cell, paste and add date stamp, then cut
Windows("WorkSheet.xls").Activate
Sheets("Data Sheet").Activate
Range("A1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Selection.Cut
'Paste to the first available row of pivot data sheet
Set wksPasteTo = ActiveWorkbook.Sheets("Pivot Data")
Set rngPasteTo = wksPasteTo.Range("A2")
'Loop the process until it finds a blank cell
Do Until rngPasteTo = ""
Set rngPasteTo = rngPasteTo.Offset(1)
Loop
'Paste the content
wksPasteTo.Paste rngPasteTo
'Select the first cell in the sheet where you've just pasted to
Application.GoTo ActiveWorkbook.Sheets("Pivot Data").Range("A1")
'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
Windows("Sheet1").Select
'ActiveSheet.Delete
Application.DisplayAlerts = True
On Error GoTo 0
Dim LR As Integer
Range("AK2").Select
Selection.FormulaArray = _
"=ISNUMBER(MATCH(1,(R1C3:R[-1]C[-34]=RC[-34])*(R1C24:R[-1]C[-13]=RC[-13])*(R1C26:R[-1]C[-11]=RC[-11]),0))"
LR = Range("AJ" & Rows.Count).End(xlUp).Row
Range("AK2").AutoFill Destination:=Range("AK2:AK" & LR), Type:=xlFillDefault
Cells.Select
Selection.AutoFilter
Selection.AutoFilter Field:=37, Criteria1:="TRUE"
Cells.Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Delete Shift:=xlUp
Selection.AutoFilter Field:=37, Criteria1:="FALSE"
Cells.Select
Selection.AutoFilter
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
With Selection.Interior
.ColorIndex = 16
.Pattern = xlSolid
End With
Selection.Font.ColorIndex = 3
Range("A1").Select
ActiveCell.FormulaR1C1 = "FIRM TYPE"
Range("B1").Select
ActiveCell.FormulaR1C1 = "JOB TITLE"
Range("C1").Select
ActiveCell.FormulaR1C1 = "COMPANY"
Range("D1").Select
ActiveCell.FormulaR1C1 = "ADDRESS LINE 1"
Range("E1").Select
ActiveCell.FormulaR1C1 = "ADDRESS LINE 2"
Range("F1").Select
ActiveCell.FormulaR1C1 = "ADDRESS_LINE_3"
Range("G1").Select
ActiveCell.FormulaR1C1 = "CITY"
Range("H1").Select
ActiveCell.FormulaR1C1 = "STATE"
Range("I1").Select
ActiveCell.FormulaR1C1 = "ZIP"
Range("J1").Select
ActiveCell.FormulaR1C1 = "FIRST NAME"
Range("K1").Select
ActiveCell.FormulaR1C1 = "LAST NAME"
Range("L1").Select
ActiveCell.FormulaR1C1 = "PHONE AREA CODE"
Range("M1").Select
ActiveCell.FormulaR1C1 = "PHONE NUMBER"
Range("N1").Select
ActiveCell.FormulaR1C1 = "PHONE EXTENSION"
Range("O1").Select
ActiveCell.FormulaR1C1 = "FAX AREA CODE"
Range("P1").Select
ActiveCell.FormulaR1C1 = "FAX NUMBER"
Range("Q1").Select
ActiveCell.FormulaR1C1 = "FAX EXTENSION "
Range("R1").Select
ActiveCell.FormulaR1C1 = "EMAIL"
Range("S1").Select
ActiveCell.FormulaR1C1 = "WEB SITE"
Range("T1").Select
ActiveCell.FormulaR1C1 = "CATEGORIES "
Range("U1").Select
ActiveCell.FormulaR1C1 = "(******) REPORT NUMBER"
Range("V1").Select
ActiveCell.FormulaR1C1 = "REPORT VERSION NUMBER"
Range("W1").Select
ActiveCell.FormulaR1C1 = "PROJECT PUBLISH DATE"
Range("X1").Select
ActiveCell.FormulaR1C1 = "PROJECT TITLE"
Range("Y1").Select
ActiveCell.FormulaR1C1 = "PROJECT TYPE"
Range("Z1").Select
ActiveCell.FormulaR1C1 = "PROJECT ACTION STAGE"
Range("AA1").Select
ActiveCell.FormulaR1C1 = "PROJECT VALUATION (HIGH VALUE)"
Range("AB1").Select
ActiveCell.FormulaR1C1 = "PROJECT BID DATE"
Range("AC1").Select
ActiveCell.FormulaR1C1 = "PROJECT ADDRESS LINE 1"
Range("AD1").Select
ActiveCell.FormulaR1C1 = "PROJECT ADDRESS LINE 2"
Range("AE1").Select
ActiveCell.FormulaR1C1 = "PROJECT CITY"
Range("AF1").Select
ActiveCell.FormulaR1C1 = "PROJECT STATE CODE"
Range("AG1").Select
ActiveCell.FormulaR1C1 = "PROJECT COUNTY"
Range("AH1").Select
ActiveCell.FormulaR1C1 = "PROJECT COUNTRY CODE"
Range("AI1").Select
ActiveCell.FormulaR1C1 = "PROJECT ZIP"
Range("AJ1").Select
ActiveCell.FormulaR1C1 = "DATE ADDED"
Columns("AK:AK").Select
Selection.ClearContents
'Sub deleteDuplicate(WSName As String)
'cRow = 2
'Do While IsEmpty(Worksheets("Pivot Data").Cells(cRow, 1)) = False 'change sheet name
'cRow2 = cRow + 1
'Do While IsEmpty(Worksheets("Pivot Data").Cells(cRow2, 1)) = False
'foundDuplicate = True
'For cCol = 1 To 35
'If Worksheets("Pivot Data").Cells(cRow, cCol).Value <> Worksheets("Pivot Data").Cells(cRow2, cCol).Value Then
'foundDuplicate = False
'Exit For
'End If
'Next
'If foundDuplicate = True Then
'Worksheets("Pivot Data").Rows(cRow2).Delete xlShiftUp
'Worksheets("Pivot Data").Rows(cRow2).Delete xlShiftUp 'guess
'Else
'cRow2 = cRow2 + 1
'End If
'Loop
'cRow = cRow + 1
'Loop
'End of old delete duplicates
'Sort all data by the date added with the newest first
Sheets("Pivot Data").Activate
Range("A1:AJ65536").Sort Key1:=Range("AJ2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'refresh pivote charts
Sheets("Region 1.1").Select
Range("A3").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Application.CutCopyMode = False
ActiveSheet.PivotTables("PivotTable2").PivotCache.Refresh
'Date Stamp for pivot table data highlighting
Sheets("Region 1.1").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add Border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left justify chart and center title bar
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("1.2").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("1.3").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("Region 2.1").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("2.2").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("2.3").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("Region 3.1").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("3.2").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Date Stamp for pivot table data highlighting
Sheets("3.3").Select
Range("A4").Select
Range("A4").FormulaR1C1 = Date
'Add border
Range("A9").Select
Selection.CurrentRegion.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
'Left Justify chart and center title row
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Rows("9:9").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'Hide Sheet and save worksheet
Sheets("Data Sheet").Activate
'ActiveSheet.Visible = False
Sheets("Pivot Data").Activate
'ActiveWorksheet.Protect Structure:=True, Windows:=False
ActiveWorkbook.Save
End SubHere is the code. If this is not readible enough I can attach a file, but I will have to work on an example that I am able to post. Please let me know, any insight would be greatly appreciated.
Thanks in advance for the help,
Dawson
