Sub AddAdjustment()
'
' AddAdjustment Macro
'
Columns("D:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Columns("D:D").Select
With Range("D13").Select
ActiveCell.FormulaR1C1 = "Adjustment 1"
Range("D13").Select
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D18").Select
End Sub
I have a worksheet where I want to insert a column with the name "Adjustment #" at the top of the column. Each time I run the macro I want it to be Adjustment 1, Adjustment 2, Adjustment 3, etc....
How would this be possible? I can insert the columns but I cannot figure out how to make the name advance in number every time. Thanks!
Well, based on your question and provided code - here is the possible solution:
Option Explicit
Sub AddAdjustment()
Static colNo As Long
colNo = colNo + 1
Cells(1, 4).EntireColumn.Insert CopyOrigin:=xlFormatFromLeftOrAbove
With Cells(13, 4)
.Value = "Adjustment " & colNo
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlTop
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.EntireColumn.AutoFit
End With
Cells(18, 4).Select
End Sub
Related
I've been working on a Macro in Excel that should go through every sheet in the workbook, count the number of rows in a given sheet, and then format those rows. The other day I was able to run it successfully, with the macro formatting the entire workbook, however the next time I attempted to run it, the value for the number of rows did not update, and it only formatted the rest of the sheets up to the number of rows in the first sheet (i.e. if the first sheet is 22 rows long, it will format every sheet, but only the first 22 rows of that sheet, leaving the rest unformatted). I have attempted trying some changes to the macro, but cannot figure out how to resolve the issue so that the row counter resets for each sheet it loops through. Any help in trying to get this macro working is appreciated.
The macro as I currently have it written is as follows:
Sub Formatting()
'
' Formatting Macro
'
' Keyboard Shortcut: Ctrl+Shift+F
'
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
lr = Cells(Rows.Count, "A").End(xlUp).Row
Range("$A$1:$X$" & lr).Select
With Selection.Font
.Name = "Century"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("G:G").Select
Selection.ColumnWidth = 75
With Selection
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Cells.Select
Cells.EntireRow.AutoFit
Range("A1").Select
End With
Next ws
End Sub
For the sake of making your formatting subroutine more specific, I have pulled out the formatting itself to private subroutines, so you can see what you're working with. You format a designated range and its font, then separately format column G; both of which add bulk to your base functions and are repeated.
Beyond that, I have removed the Select items, aside from the "A1" select to reset position on each sheet.
Imparting my comments on your code (untested):
Sub Formatting()
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
With ws
Dim lr as Long: lr = .Cells(.Rows.Count, "A").End(xlUp).Row
DesignatedRangeFormatting .Range("$A$1:$X$" & lr)
ColumnGFormatting .Columns("G")
.Cells.EntireRow.AutoFit
.Select
.Range("A1").Select
End With
Next ws
End Sub
Private Sub DesignatedRangeFormatting(rng as Range)
With rng.Font
.Name = "Century"
.Size = 12
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With rng
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Private Sub ColumnGFormatting(rng as Range)
With rng
.ColumnWidth = 75
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
Edit1: Added .Select before .Range("A1").Select to ensure the current sheet is selected, which resolves the RTE1004.
Before asking this question I have already tried solutions previously stated in the forum.
Have Excel VBA wait for PowerQuery data refresh to continue
and
How to wait for a Power Query refresh to finish? I've tried "DoEvents" with "BackgroundQuery = False", and more, nothing works
My goal: Refresh the table, format table(resize, align, and hide data), replace blank cells with "-".
The format and replace blank procedures are written separately which I call after query refresh.
When I step through the code everything works perfect. However, when I run the macro the query refreshes and blanks are replaced, but the data is not formatted how I specified.
I'm not sure if this is due to a flaw in the code, a byproduct of working on a slow network, or me just being a rookie at all of this and not realizing what I'm doing wrong.
Solutions I've tried: 1. Disable "Background Refresh" in the properties section. 2. Wrote the refresh piece both ways:
With ActiveWorkbook.Connections("Query - QueryName").OLEDBConnection
brfresh = .BackgroundQuery
.BackgroundQuery = False
.Refresh
.BackgroundQuery = brfresh
End With
and
ActiveWorkbook.Connections("Query - QueryName").Refresh
I also tried adding an application.wait time of 5 seconds after refresh.
Here is the Module if this helps:
Sub RefreshMRIQuery()
Dim brfresh As Boolean
Dim StartT As Date
Dim EndT As Date
StartT = Now
EndT = StartT + TimeValue("00:00:05")
Sheets("MRI").Select
Range("A1").Select
With ActiveWorkbook.Connections("Query - MASTER ROLLER INPUT").OLEDBConnection
brfresh = .BackgroundQuery
.BackgroundQuery = False
.Refresh
.BackgroundQuery = brfresh
End With
Application.Wait EndT
Range("A1").Select
RemoveBlanks
Range("A1").Select
FormatMRITable
Range("A1").Select
End Sub
Sub FormatMRITable()
Columns("B:B").Select
Selection.EntireColumn.Hidden = True
Columns("C:C").Select
Selection.EntireColumn.Hidden = True
Rows("1:1").RowHeight = 44.25
Range("MASTER_ROLLER_INPUT").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Columns("G:G").ColumnWidth = 10
Columns("G:G").ColumnWidth = 13.57
Columns("H:H").ColumnWidth = 11.57
Columns("I:I").ColumnWidth = 11.29
Columns("I:I").ColumnWidth = 14
Columns("J:J").ColumnWidth = 12.71
Range("A2").Select
End Sub
Public Sub RemoveBlanks()
Dim MRI As ListObject
Set MRI = Worksheets("MRI").ListObjects("MASTER_ROLLER_INPUT")
Dim r As Range
For Each r In MRI.DataBodyRange
If r.Value = "" Then r.Value = "-"
Next r
End Sub
Sorry if the formatting isn't correct and/or if I have unnecessary steps-I've been learning from scratch for about a month and Google has been the source of all my programming knowledge.
If I need to elaborate on anything please let me know, thanks!
I have a file that is exported by the system each week that needs to be modified slightly in each sheet and all sheets to be renamed based on one cell in that particular cell (E7). I am not able to get it to loop no matter how hard i try. Any ideas what i am missing? I assume it has to do with that 'konstandst' variable and how i name sheets, but can fix..
Sub Formateraom()
' Format and change name of the sheet
Dim ws As Worksheet
Dim weekNR As Variant
Dim konstnadst As Variant
weekNR = InputBox("What week number is it?")
For Each ws In Worksheets
Set ws = ActiveSheet
konstnadst = Range("E7")
Range("A2:C2").Select
Selection.ClearContents
Range("A5:T5").Select
Selection.ClearContents
Columns("C:C").ColumnWidth = 75#
Rows("5:7").Select
With Selection
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
With Selection
.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
Columns("H:H").ColumnWidth = 13
Range("H7,M7,G7").Select
Range("G7").Activate
Selection.NumberFormat = "m/d/yyyy"
Columns("M:M").ColumnWidth = 13
Columns("G:G").ColumnWidth = 13
Range("C3").Select
ActiveCell.FormulaR1C1 = weekNR
Range("C4").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("C3").Select
With Selection
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
ActiveSheet.Name = "Fakturaunderlag " & konstnadst & " " & weekNR
Next
End Sub
Sending gigantic ball of karma to whoever can point me to the right direction!
Set ws = ActiveSheet would always set the current loop sheet (i.e. ws) to the currently Active one.
this way you'd always get the same sheet, the one being active before the loop begins
so you'd simply have to change
Set ws = ActiveSheet
to
ws.Activate
thus making the current loop sheet the active one
but although tha above patch may (seem to) work, it is also a bad coding habit and you're warmly invited to avoid Activate/ActiveXXX/Select/Selection pattern and switch to a direct and qualified up to the worksheet (and workbook, if there could be more than one open at the time the macro is being run) Range reference
so your code could become the following:
Option Explicit
Sub Formateraom()
' Format and change name of the sheet
Dim ws As Worksheet
Dim weekNR As Variant
Dim konstnadst As Variant
weekNR = InputBox("What week number is it?")
For Each ws In Worksheets
With ws ' reference the current loop sheet. inside the 'With ... End With' block, all its members are accessed by means of a dot (.)
konstnadst = .Range("E7") ' initialize 'konstnadst' to referenced sheet cell E7 value
.Range("A2:C2").ClearContents
.Range("A5:T5").ClearContents
.Columns("C:C").ColumnWidth = 75#
With .Rows("5:7") ' reference referenced sheet rows 5 to 7
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
End With
.Columns("H:H").ColumnWidth = 13
.Range("H7,M7,G7").NumberFormat = "m/d/yyyy"
.Columns("M:M").ColumnWidth = 13
.Columns("G:G").ColumnWidth = 13
.Range("C3").FormulaR1C1 = weekNR
With .Range("C4") ' reference referenced sheet cell C4
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With .Range("C3") ' reference referenced sheet cell C3
.HorizontalAlignment = xlRight
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
.Name = "Fakturaunderlag " & konstnadst & " " & weekNR ' change the name of the referenced sheet
End With
Next
End Sub
The below question is actually a case where you need to use .Select. In almost every other instance, never use it.
Question regarding how to export xlsx as pdf
This question should help you learn how to open an excel file using a file dialog box
I'm unsure of what you want to do with weekNR considering you're doing this with it later:
ActiveCell.FormulaR1C1 = weekNR
So I'm going to ignore it until I get more info about it.
Since konstnadst is a Range object, as you have assigned it, I would suggest declaring it as a Range object, with a reference to the worksheet you're working with, like so:
Dim konstandadst As Range
'you need to Set objects such as Ranges, Worksheets, Workbooks, ect.
Set konstandadst = whateverWsThisIs.Range("E7")
Using Range.Activate is the equivalent of clicking the range, which seems to be useless in your circumstance, so get rid of that.
Using:
Range1.Select
Range2.Select
Range3.Select
Results in you only selecting Range3 when this block finishes.
I would highly suggest never using .Select, and instead create reference variables to your ranges to work with them directly like so:
'these select cell A1
Set MyRange = ws.Range("A1")
Set MyRange = ws.Cells(1,1)
'this selects column B
Set MyRange = ws.Range("B:B")
'this selects the row from A1 to B1
Set MyRange = ws.Range(ws.Cells(1,1), ws.Cells(1,2))
'this selects a table defined from A1 to C2
Set MyRange = ws.Range(ws.Cells(1,1), ws.Cells(2,3))
Don't do this:
For Each ws In Worksheets
Do this because you want to explicitly tell VBA the workbook in which you're referencing the Worksheets collection:
For Each ws In ThisWorkbook.Worksheets
Or if you're a freak like me:
For Each ws In Excel.Application.ThisWorkbook.Worksheets
Here are a few relevant operations you can do with Range objects (more here):
'clears the values in the cells
MyRange.ClearContents
'clears the formatting and formulas in the cells
MyRange.Clear
'adjust column width
MyRange.ColumnWidth = someNumber
'adjust row height
MyRange.RowHeight = someOtherNumber
'eliminate indents (i think)
MyRange.IndentLevel = 0
'change the orientation
MyRange.Orientation = 0
After you have set reference variables to the ranges you want, you can use them like this:
With MyRange
'do the stuff here
End With
Instead of:
With Selection
'bad stuff here, don't do the stuff
End With
I am looking to copy data from a column to a column on another sheet.
Sheet one has a list of ID numbers (starting at F3) next to clock in and out times. There will be anything from 5 - 31 entries of the ID number, before moving to the next employee.
On sheet two is a time sheet with one row per day. The first row of each employee is blank (starting at C8) with the balance of data on that row (name, trade, site etc.) being a reference to this blank cell. There will be anywhere from 29 - 31 rows per employee on sheet two, to allow for all calendar days of the month.
I am trying to search sheet one for the next unique ID, then copy that value to the next available blank cell on sheet two.
The code I have works (sort of) when referencing between sheets and filling in the first value. Selecting the next unique value and then looping till the end of the list is eluding me.
Image of spreadsheets: https://www.dropbox.com/s/vg08uxb9kma2tza/VBA%20Help.jpg?dl=0
Sub TimesheetID()
ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
FinalRow = Cells(Rows.Count, 2).End(xlUp).Row
Worksheets("All Go").Activate
Range("E3").Select
Selection.Copy
Worksheets("Timesheet").Activate
Range("C7").Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
Worksheets("All GO").Activate
GoAgain:
ThisRow = ThisRow + 1
If ThisRow > Application.Rows.Count Then
Cells(ThisRow - 1, ThisCol).Select
Beep
Exit Sub
End If
If Cells(ThisRow, ThisCol).Value = ThisVal Then
GoTo GoAgain
Else
Cells(ThisRow, ThisCol).Select
End If
ActiveCell.Select
Selection.Copy
Worksheets("Timesheet").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
With Selection.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection.Font
.Name = "Arial"
.Size = 11
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = 1
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = True
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
End Sub
This example uses two dictionaries and the Dictionary.Exists method to create an array of unique values from the range A1:A50.
Option Explicit
Sub UniqueList()
Dim UniqueDic As Object
Dim AllDic As Object
Dim rng As Range
Dim c As Range
Dim UniqueArray() As Variant
Set UniqueDic = CreateObject("Scripting.Dictionary")
Set AllDic = CreateObject("Scripting.Dictionary")
Set rng = ActiveSheet.Range("$A$1:$A50")
For Each c In rng.Cells
If Not AllDic.Exists(c.Value2)
UniqueDic.Add c.Value2, c.Row
AllDic.Add c.Value2, c.Row
Else
If Not UniqueDic.Exists(c.Value2) Then
UniqueDic.Remove c.Value2
End If
End If
Next
UniqueArray() = Array(UniqueDic.Keys)
End Sub
If a range is traversed and a dictionary, "AllDic", gains a key equal to the cell value when Not AllDic.Exists Cell.Value evaluates to true; then AllDic.Keys will return an array of values unique to "AllDic" but not necessarily unique to the range.
Using two dictionaries, "AllDic" and "UniqueDic", if they both get the same key when Not AllDic.Exists Cell.Value evaluates to true, but when it is false "UniqueDic" will lose a key if Not UniqueDic.Exists Cell.Value is true; then keys from both dictionaries will return arrays with unique values, however, "UniqueDic" will not have any values that repeat in the range.
I managed to work around using this:
Sub TDSFillTest()
Dim BadgeNo As Integer
Dim BlankCount As Integer
Dim LoopCount As Integer
LoopCount = 1
ThisVal = ActiveCell.Value
ThisRow = ActiveCell.Row
ThisCol = ActiveCell.Column
Worksheets("Timesheet").Activate 'Go to Timesheet and count blank cells
BlankCount = Range(("C8"), Cells(Rows.Count, 2).End(xlUp)).Cells.SpecialCells(xlCellTypeBlanks).Count
Worksheets("All Go").Activate 'Starting Point
Range("F3").Copy Worksheets("Timesheet").Range("C8") 'First Value to Timesheet
Worksheets("All Go").Activate ' Return to TDS
Range("F3").Select
Do Until LoopCount > BlankCount
Worksheets("All Go").Activate
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> ActiveCell.Offset(-1, 0).Value Then Exit Do
Loop
ActiveCell.Copy
Worksheets("Timesheet").Activate
ActiveCell.Offset(1, 0).Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
LoopCount = LoopCount + 1
Loop
End Sub
I'm going to take yours and run through it in detail so I can learn the more efficient methods. Thanks!
I am trying to automate some pieces of my reports for work. I want to have a macro that will take all the raw data in a worksheet and create/design the same pivot table every time.
I have been able to create a normal table in this way by avoiding absolutes such as Ctrl+shft+ down arrow to select all the data but with Pivot Tables I run into this error:
Just to be as specific as possible. With my macro use I have been unable to:
Create a Pivot Table
Rename a worksheet
Sort the values from largest to smallest.
In all my macros, these 3 things will cause it to crash in a run time error.
Is there anyway to modify the code to allow these three things to work?
Here is my Macro code. The three things I want to accomplish are in this pivot table macro. Sorry for any miss clicks in the creation of the macro. Thanks for any help you guys might provide.
Sub Create_pivotTable()
'
' Create_pivotTable Macro
'
'
Cells.Select
Sheets.Add
ActiveWorkbook.Worksheets("Pivot Table").PivotTables("PivotTable6").PivotCache. _
createPivotTable TableDestination:="Sheet1!R3C1", TableName:="PivotTable1" _
, DefaultVersion:=xlPivotTableVersion14
Sheets("Sheet1").Select
Cells(3, 1).Select
Sheets("Sheet1").Select
Sheets("Sheet1").Move Before:=Sheets(5)
Sheets("Sheet1").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Debit Party Name")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Credit Party Name")
.Orientation = xlRowField
.Position = 2
End With
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Original Amount"), "Count of Original Amount", _
xlCount
ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
"PivotTable1").PivotFields("Transaction Date"), "Count of Transaction Date", _
xlCount
Sheets("Sheet1").Name = "Piv Tab"
Rows("1:2").Select
Range("A2").Activate
Selection.Delete Shift:=xlUp
Range("A1").Select
ActiveSheet.PivotTables("PivotTable1").CompactLayoutRowHeader = _
"ORIGINATORS | BENEFICIARY'S"
Range("B1").Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields( _
"Count of Original Amount")
.Caption = "Amount"
.Function = xlSum
End With
Range("C1").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Count of Transaction Date") _
.Caption = "Count"
Range("B2").Select
Range(Selection, Selection.End(xlDown)).Select
With ActiveSheet.PivotTables("PivotTable1").PivotFields("Amount")
.NumberFormat = "_($* #,##0.00_);_($* (#,##0.00);_($* ""-""??_);_(#_)"
End With
Range("B2").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Debit Party Name"). _
AutoSort xlDescending, "Amount", ActiveSheet.PivotTables("PivotTable1"). _
PivotColumnAxis.PivotLines(1), 1
Range("B4").Select
ActiveSheet.PivotTables("PivotTable1").PivotFields("Credit Party Name"). _
AutoSort xlDescending, "Amount", ActiveSheet.PivotTables("PivotTable1"). _
PivotColumnAxis.PivotLines(1), 1
Columns("D:D").ColumnWidth = 45.86
Range("D1").Select
ActiveCell.FormulaR1C1 = "Analysis"
Range("B1").Select
ActiveSheet.PivotTables("PivotTable1").TableStyle2 = "PivotStyleMedium3"
Range("A1").Select
Selection.Copy
Range("D1").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
Selection.Font.Bold = True
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range(Selection, Selection.End(xlDown)).Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Columns("C:C").Select
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlGeneral
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("D7").Select
End Sub