I am trying to create a module to share functionality across a number of worksheets within a single workbook. All works fine apart from some filter code.
The code below works fine if I place it in a single worksheet
ActiveSheet.PivotTables("PivotTable1").PivotFields("MyField"). _
ClearValueFilters
ActiveSheet.PivotTables("PivotTable1").PivotFields("MyField").PivotFilters.Add Type:=xlValueIsBetween, DataField:=ActiveSheet.PivotTables _
("PivotTable1").PivotFields("MyValue"), Value1:=bottom, Value2:=Top
However, I want to use this code in my Module and send it the following: Pivot Table Name, Row PivotField, Value Pivot fieldtop "between" valuebottom "between" value
Something like:
The sheet call
Call Mod_Filter("PivotTable1", "MyRowFieldName", "MyValueFieldName", 0, intvalue)
The Module code
Public Sub Mod_Filter(ByRef PT_Name As String, ByRef StaticField As String, ByRef Filter_field As String, bottom As Double, Top As Double)
ActiveSheet.PivotTables(PT_Name).PivotFields(StaticField).ClearValueFilters
ActiveSheet.PivotTables(PT_Name).PivotFields(StaticField).PivotFilters.Add Type:=xlValueIsBetween, DataField:=ActiveSheet.PivotTables _
(PT_Name).PivotFields(Filter_field), Value1:=bottom, Value2:=Top
End Sub
However, I cannot get this to work. Any suggestions??
So I'm using the "St" Row to filter the YTD% based on a value selected from a dropdown combo box
Requirement:
To filter a Pivot RowField based on a Pivot DataField
This procedure uses the PivotField.SourceName to validate & set the DataField to apply the Filter Type and Values.
Sub Ptb_Filter_Between(WshTrg As Worksheet, _
sFldTrg As String, sFldDta As String, dFromVal As Double, dToValue As Double)
Dim pTbl As PivotTable, pFldDta As PivotField
Rem Application Settings - OFF
Application.ScreenUpdating = False
Application.EnableEvents = False
Rem Set PivotTable
'Using Index 1 as OP confirmed there is only one PivotTable per Sheet
'If this condition change then PivotTable Index should be provided as an argument
Set pTbl = ActiveSheet.PivotTables(1)
With pTbl
Rem Set DataField - User provides the Data Field
For Each pFldDta In .DataFields
If pFldDta.SourceName = sFldDta Then Exit For
Next
If pFldDta Is Nothing Then GoTo ExitTkn
Rem Filter PivotField
.ClearAllFilters 'Use this line to clear all PivotTable Filters
On Error GoTo ExitTkn
With .PivotFields(sFldTrg)
.ClearAllFilters 'This line clears all PivotField Filters
.PivotFilters.Add2 Type:=xlValueIsBetween, _
DataField:=pFldDta, Value1:=dFromVal, Value2:=dToValue
End With: End With
ExitTkn:
Rem Application Settings - ON
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
These are some samples of how to call the procedure:
sFldTrg = "Type"
sFldDta = "Amount"
dFromVal = 25000
dToValue = 30000
Call Ptb_Filter_Between(Worksheet Object, sFldTrg, sFldDta, dFromVal, dToValue)
sFldTrg = "Type"
sFldDta = "YTD%"
dFromVal = 0.3
dToValue = 0.35
Call Ptb_Filter_Between(Worksheet Object, sFldTrg, sFldDta, dFromVal, dToValue)
sFldTrg = "Row"
sFldDta = "YTD%"
dFromVal = 0.1 'To set from value as 10%
dToValue = 0.2 'To set to value as 20%
Call Ptb_Filter_Between(Worksheet Object, sFldTrg, sFldDta, dFromVal, dToValue)
Related
I have a pivot table structure that looks like (i.e. there are three entries in the "ROWS" box in the pivottable UI)
Category
SubCategory
Sub Sub Category
I know that I can get all the Categories, subcategories, and sub-sub categories by doing (in VBA) PT.PivotFields(3).PivotItems(), PT.PivotFields(2).PivotItems() and PT.PivotFields(1).PivotItems() respectively, where PT is my pivottable.
How can I find out which subcategories are in each category, and same for sub sub categories in categories?
I tried using PT.PivotFields(3).PivotItems()(1).ChildItems() but I get an error <Unable to get the ChildItems property of the PivotItem class> and same for trying ParentItem.
Any idea how I can do this?
An example of what I am looking for. Take the pivot table below, and enumerate (in some way) that:
a has subcategories d,e; b has subcategories e,f; c has sub categories d,e,f; and it would be the same if there were multiple levels on the columns position.
Requirement:
To build a table showing all the Items combinations for all RowFields and ColumnsFields of a given PivotTable.
Solution:
This can be achieved by setting some of the properties and methods of the PivotTable and the Row, Column and Data Fields as follows:
Set these PivotTable properties:
RowGrand, ColumnGrand, MergeLabels, RowAxisLayout
Set these properties for the ColumnFields:
Orientation
Set these properties for the RowFields:
RepeatLabels, Subtotals
Set these properties for the DataFields:
Orientation
Procedure:
Sub PivotTable_Hierarchy_Rows_And_Columns(pt As PivotTable, _
aPtHierarchy As Variant, blClearFilters As Boolean, blIncludeCols As Boolean)
This procedure adjusts all the above-mentioned properties in order to display the PivotTable in a “table like” format generating an array with the PivotTable’s Hierarchy. It also provides the options to clear or not the PivotTable filters and to include or not the ColumnFields in the hierarchy.
Parameters:
Pt: Target PivotTable
aPtHierarchy: Array output containing the hierarchy of the target PivotTable.
blClearFilters: Boolean. Determines whether to clear or not the all PivotTable filters.
blIncludeCols: Boolean. Used to include or not the ColumnFields in the output hierarchy.
Syntax:
Call PivotTable_Hierarchy_Rows_And_Columns(pt, aPtHierarchy, blClearFilters, blIncludeCols)
VBA:
Sub PivotTable_Hierarchy_Rows_And_Columns(pt As PivotTable, _
aPtHierarchy As Variant, blClearFilters As Boolean, blIncludeCols As Boolean)
Dim pf As PivotField
Rem PivotTable Properties & Methods
With pt
.RowGrand = False
.ColumnGrand = False
.MergeLabels = False
.RowAxisLayout xlTabularRow
If blClearFilters Then .ClearAllFilters
End With
Rem ColumnFields Properties
For Each pf In pt.ColumnFields
If blIncludeCols Then
pf.Orientation = xlRowField
Else
pf.Orientation = xlHidden
End If: Next
Rem RowFields Properties
For Each pf In pt.RowFields
With pf
On Error Resume Next
.RepeatLabels = True
.Subtotals = Array(False, False, False, False, _
False, False, False, False, False, False, False, False)
On Error GoTo 0
End With: Next
Rem DataFields Properties
For Each pf In pt.DataFields
pf.Orientation = xlHidden
Next
Rem Set Hierarchy Array
aPtHierarchy = pt.RowRange.Value2
End Sub
Example:
Assuming we need to obtain the Hierarchy of the PivotTable in fig. 1.
Note that the PivotTable has some filters applied.
The procedure PivotTable_Hierarchy_Rows_And_Columns can be called as follows depending on the required outcome:
Sub PivotTable_Hierarchy_Rows_And_Columns_TEST()
Dim pt As PivotTable, aPtHierarchy As Variant
'Set PivotTable - Change worksheet and pivottable name as required
Set pt = ThisWorkbook.Worksheets("Summary").PivotTables("PtTst")
'1. To obtain the Hierarchy for Rows and Columns, clearing all the filters applied to the PivotTable try this:
Call PivotTable_Hierarchy_Rows_And_Columns(pt, aPtHierarchy, True, True) 'See results in Fig. R1 (Table & Array)
‘2. To obtain the Hierarchy for Rows only, clearing all the filters applied to the PivotTable try this:
Call PivotTable_Hierarchy_Rows_And_Columns(pt, aPtHierarchy, True, False) 'See results in Fig. R2 (Table & Array)
'3. To obtain the Hierarchy for Rows and Columns with the filters currently applied to the PivotTable try this:
Call PivotTable_Hierarchy_Rows_And_Columns(pt, aPtHierarchy, False, True) 'See results in Fig. R3 (Table & Array)
'4. To obtain the Hierarchy for Rows only with the filters currently applied to the PivotTable try this:
Call PivotTable_Hierarchy_Rows_And_Columns(pt, aPtHierarchy, False, False) 'See results in Fig. R4 (Table & Array)
End Sub
Fig. 1
Fig. R1
Fig. R2
Fig. R3
Fig. R4
For additional information on the resources used see the following pages:
PivotTable Object (Excel)
PivotTable.RowAxisLayout Method (Excel)
PivotField Object (Excel)
I don't know how many categories and sub-categories you have, but you can put everything to a multiple array (matrix) and then manage like you want.
Try this:
Sub GetCategories_SubCat()
Dim PTable As PivotTable
Dim matrix() As Variant
Dim matrix_s() As Variant
Dim msg$
Set PTable = ActiveSheet.PivotTables("PT")
ReDim matrix(1 To PTable.RowFields.Count)
For i = 1 To PTable.RowFields.Count
matrix(i) = PTable.RowFields(i)
For j = 1 To PTable.RowFields(i).PivotItems.Count
ReDim matrix_s(1 To PTable.RowFields.Count, 1 To PTable.RowFields(i).PivotItems.Count)
matrix_s(i, j) = PTable.RowFields(i).PivotItems(j)
Next j
Next i
End Sub
I think you can use GetPivotData function to try to obtain value for each set of pivot fields. If no error is thrown, you know that certain category has certain sub and sub-sub category. See my rough code, for table with three levels:
Sub ExaminePT()
Dim pt As PivotTable
Dim pf As PivotField
Dim Lev1 As PivotField
Dim Lev2 As PivotField
Dim lev3 As PivotField
Dim pi1 As PivotItem
Dim pi2 As PivotItem
Dim pi3 As PivotItem
Dim checkVal As Double
Set pt = ActiveSheet.PivotTables(1)
For Each pf In pt.PivotFields
If pf.Orientation = xlRowField Then
Select Case pf.Position
Case Is = 1
Set Lev1 = pf
Case Is = 2
Set Lev2 = pf
Case Is = 3
Set lev3 = pf
End Select
End If
Next pf
For Each pi1 In Lev1.PivotItems
For Each pi2 In Lev2.PivotItems
For Each pi3 In lev3.PivotItems
On Error Resume Next
checkVal = pt.GetPivotData("Incremental Benefits 2017", Lev1.Name, pi1.Name, _
Lev2.Name, pi2.Name, lev3.Name, pi3.Name)
If Err.Number = 0 Then Debug.Print pi1 & "| " & pi2 & "| " & pi3
On Error GoTo 0
Next pi3
Next pi2
Next pi1
End Sub
In the first loop I assign category, sub- and subsubcategory to variables, and then do what I had suggested above. The results are written in the Immediate window, this is sketch of the solution.
Probably, with little effort some could turn it into more universal procedure to examine pivot tables for any number of nested levels.
I'm using VBA to perform a search on a pivot field and I want to be able to do a search based on whether the field contains a portion of the string but am unsure of how to do this without checking for the whole value. Bellow is what I currently have:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'This line stops the worksheet updating on every change, it only updates when cell
'P4 is touched
If Intersect(Target, Range("B4")) Is Nothing Then Exit Sub
'Set the Variables to be used
Dim pt As PivotTable
Dim Field As PivotField
Dim NewPull As String
'Here you amend to suit your data
Set pt = Worksheets("Pull Code Search").PivotTables("PivotTable1")
Set Field = pt.PivotFields("Pull Code")
If IsEmpty(Range("B3").Value) = True Then
NewPull = "(All)"
Else
NewPull = Worksheets("Pull Code Search").Range("B3").Value
End If
'This updates and refreshes the PIVOT table
With pt
Field.ClearAllFilters
Field.CurrentPage = NewPull
If NewPull = "(All)" Then
ActiveSheet.PivotTables(1).PivotFields(1).ShowDetail = False
End If
pt.RefreshTable
End With
End Sub
Use INSTR.
This function returns the position of first occurrence of substring in a string. You no need to loop through the whole string.
If your portion of the string (substring) exists in the actual "string", this function returns a positive value.
"The INSTR function can only be used in VBA code in Microsoft Excel."
The syntax
InStr( [start], string, substring, [compare] )
More description here:
https://www.techonthenet.com/excel/formulas/instr.php
this is a simple stock price change code
my code is function(with parameters)
Function VanillaCall(S0 As Single, Exercise As Single, Mean As Single, sigma As Single, _
Interest As Single, Time As Single, Divisions As Integer, Runs As Integer) As Single
deltat = Time / Divisions
interestdelta = Exp(Interest * deltat)
up = Exp(Mean * deltat + sigma * Sqr(deltat))
down = Exp(Mean * deltat - sigma * Sqr(deltat))
pathlength = Int(Time / deltat)
piup = (interestdelta - down) / (up - down)
pidown = 1 - piup
Temp = 0
For Index = 1 To Runs
upcounter = 0
For j = 1 To pathlength
If Rnd > pidown Then upcounter = upcounter + 1
Next j
callvalue = Application.Max(S0 * (up ^ upcounter) * (down ^ (pathlength - upcounter)) - Exercise, 0) / (interestdelta ^ pathlength)
Temp = Temp + callvalue
Next Index
VanillaCall = Temp / Runs
End Function
parameters are passed from cells in excel.
i want to execute this function from button click and display return value in a cell say b12.
i have tried putting the code inside a button sub but its not working ,a call vanillacall inside sub too isnt working.
like..
private sub button1_click()
call vanillacall
end sub
Private Sub button1_click()
Range("B12").Value = vanillacall(....)
End Sub
As per your request, Pass arguments in Range like below. Below code is just for example (due to the changes in excel data)
Sub testing33()
Range("B12") = sample(Range("A5"), Range("B5"))
End Sub
Function sample(a As Range, b As Range)
sample = a.Cells.Value & ", " & b.Cells.Value
End Function
I'd do something like the below which would allow me to pick the range containing the data I want to pass to the function (as long as the range is contiguous and contains 8 cells) and pick the cell I want to output the result to.
Private Sub button1_click()
Dim inRng As Range, outRng As Range
inSelect:
Set inRng = Application.InputBox("Select Range to Calculate", Type:=8)
If inRng.Cells.Count <> 8 Then
MsgBox "Select a range with 8 cells!", vbCritical
GoTo inSelect
End If
outSelect:
Set outRng = Application.InputBox("Select Cell to Output To", Type:=8)
If outRng.Cells.Count > 1 Then
MsgBox "Select only one cell!", vbCritical
GoTo outSelect
End If
outRng.Value = VanillaCall(inRng.Cells(1), inRng.Cells(2), inRng.Cells(3), inRng.Cells(4), inRng.Cells(5), inRng.Cells(6), inRng.Cells(7), inRng.Cells(8))
End Sub
You need to get the values from the sheet and save in variables. Then pass the variables to the function. Then output the result to the sheet somewhere. You will need to adjust the range addresses and worksheet name as appropriate.
Private sub button1_click()
dim ws as worksheet
Set ws = worksheets("Sheet1") ' < change the sheet name as appropriate
dim S0 As Single
dim Exercise As Single
dim Mean As Single
dim sigma As Single
dim Interest As Single
dim Time As Single
dim Divisions As Integer
dim Runs As Integer As Single
S0 = ws.Range("B1") '< specify the cell that has this data
Exercise = ws.Range("B2") '< specify the cell that has this data
Mean = ws.Range("B3") '< specify the cell that has this data
sigma = ws.Range("B4") '< specify the cell that has this data
Interest = ws.Range("B5") '< specify the cell that has this data
Time = ws.Range("B6") '< specify the cell that has this data
Divisions = ws.Range("B7") '< specify the cell that has this data
Runs = ws.Range("B8") '< specify the cell that has this data
dim Result as Single
Result = vanillacall(S0, Exercise , Mean, sigma, Interest, Time, Divisions, Runs)
ws.Range("B10") = Result '<specify the cell where you want the result
end sub
I have the need to execute some VBA code when a sheet changes. For this I have an If-then-else situation.
In any particular row (I have a variable number of rows (i.e. line items)):
if column "Type" = Range("A") then
column "Amount" needs to be unlocked
set to the value of Range("B") and locked
else if column "Type" = Range("C") then
column "Amount" needs to be unlocked
set to the value of Range("C") and locked
else
the column "Amount" needs to unlocked.
In the worksheet change event, I unlock/lock using ActiveSheet.Protect and .Unprotect with a password from a range.
I am now trying to figure out how to do this. Specifically, how do I use the column names - like in formula's?
=== for Excel 2007+ ===
If you are using Excel 2007+, I recommend using ListObject, ListColumns and ListRows (study the object model).
Philosophy behind my approach:
Forms, Data and Reports should always be separated, so...
Gather all your data into a Table, in a dedicated sheet. Select your data and Ctrl+(T or L). Make sure every sheet has only 1 table of data.
Using Tables, you'll be able to make use of the ListObject, ListColumns and ListRows objects.
Here's the finished code for the entire thing.
Public Sub test()
IntersectColumnRows ActiveSheet, "", "Type", "Amount", Range("A1"), Range("B1"), Range("C1")
End Sub
Public Sub IntersectColumnRows(currentSheet As Worksheet, sheetPassword As String, columnTitle_Type As String, columnTitle_Amount As String, rangeA As Range, rangeB As Range, rangeC As Range)
'variable declaration
Dim listO As ListObject
Set listO = currentSheet.ListObjects(1)
'Takes care of sheet protection
Dim isSheetProtected As Boolean
isSheetProtected = currentSheet.ProtectionMode
If isSheetProtected Then _
currentSheet.Unprotect (sheetPassword)
'store your type column
Dim columnRangeType As Range
Set columnRangeType = listO.ListColumns(columnTitle_Type).Range
'store your 2nd column
Dim columnRangeAmount As Range
Set columnRangeAmount = listO.ListColumns(columnTitle_Amount).Range
'the actual routine you are asking for
Dim listR As ListRow
For Each listR In listO.ListRows
'intersect the TYPE column with the current row
Dim typeRangeIntersection As Range
Set typeRangeIntersection = Application.Intersect(listR.Range, columnRangeType)
'intersect the AMOUNT column with the current row
Dim amountRangeIntersection As Range
Set amountRangeIntersection = Application.Intersect(listR.Range, columnRangeAmount)
'the logic you required
If typeRangeIntersection.Value = rangeA.Value Then
amountRangeIntersection.Locked = False
amountRangeIntersection.Value = rangeB.Value
amountRangeIntersection.Locked = True
ElseIf typeRangeIntersection.Value = rangeC.Value Then
amountRangeIntersection.Locked = False
amountRangeIntersection.Value = rangeC.Value
amountRangeIntersection.Locked = True
Else
amountRangeIntersection.Locked = False
End If
Next
'Cleans up sheet protection
If isSheetProtected Then _
currentSheet.Protect (sheetPassword)
End Sub
Here's the "how-I-did-it":
Store the ListColumn.Range for all required columns (Type, Amount)
For-loop with every ListRow...
I intersect the ListRow.Range with the ListColumn.Range
Apply your desired logic
Beyond the code, study how...
I included the PROTECT/PASSWORD logic in there, so you can remove it if you want to.
Each variable has a very explicit name
I didn't include any hard-coded value so it remains parametric, if you need to adapt some stuff for different sheets
I need some help with copying unique records from one workbook to a master workbook please.
Each month I receive a new workbook with data and I want to be able to copy all new records in that new workbook to one master workbook which will have all the amalgamted records. There is one unique reference field which can be used for the lookup to identify a new record.
In addition to this what I want to do is update values which are in 3 columns for ALL existing records on the master workbook which might be on the new workbook.
Example
Master workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 100 50 200 xxxxxxxxxxxxxxx
111 WE 90 45 400 xxxxxxxxxxxxxxx
New workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 300 200 200 xxxxxxxxxxxxxxx
456 MA 100 500 700 xxxxxxxxxxxxxxx
Update master workbook
Ref Name Value 1 Value 2 Value 3 Description
123 TR 300 200 200 xxxxxxxxxxxxxxx
111 WE 90 45 400 xxxxxxxxxxxxxxx
456 MA 100 500 700 xxxxxxxxxxxxxxx
I'd appreciate any help with this please. Thanks
I wrote a small module that does what you want (and even more). I tried to make it as generic as possible, but I had to assert a few things and limit it somehow - otherwise it would get quickly out of hand (as I think it already did.. kind of).
The limitations/assertions are the following:
1. the records are considered to be laid out only in rows (as per your example).
2. there is no column checking during the update or insertion of values. The program assumes that both master and new workbooks contain the same columns and laid in the exact same order.
3. There is no validation check for duplicate reference values. The "ref" column that you indicate as your primary key in each data range, is assumed to contain unique values (for that data range).
Apart from those assumptions, my solution is enhanced with flexible arguments (optional or autoconfigurable - see how dataRange is determined) to allow for several types of operation.
optional colorAlertOption flag: allows updated or inserted entries to be colored in order to be more distinguisable (true by default)
optional rangeWithHeaders flag: helps to determine if the supplied dataRange argument needs to be resized (remove headers) or not (true by default)
optional refColIndex integer: the relative to the dataRange - not the whole worksheet - column number pinpointing the column containing the unique references. (1 by default)
required dataRangeNew, dataRangeMaster (Range) arguments: flexible representations of the data-ranges for the new and master datasets respectively. You can either provide them explicitly (e.g. "$A$1:$D$10") or by giving only a single cell contained anywhere within the data-range. The only predicates are that the data-range should be isolated from other possible data coexisting on the same sheet (by means of blank rows or columns) and that it contains at least 1 row.
You can call the updateMasterDataRange procedure like this:
call updateMasterDataRange (Workbooks(2).Sheets("new").Range("a1"), Workbooks(1).Worksheets("master").Range("a1"))
Notice the fully qualified data ranges, including the workbooks and the worksheets in the mix. If you don't prepend these identifiers, VBA will try to associate the unqualified Range with ActiveWorkbook or/and ActiveWorksheet, with unpredictable results.
Here goes the body of the module:
Option Explicit
Option Base 1
Public Sub updateMasterDataRange( _
ByRef dataRangeNew As Range, ByRef dataRangeMaster As Range, _
Optional refColIndexNew As Integer = 1, Optional refColIndexMaster As Integer = 1, _
Optional colorAlertOption = True, Optional rangeWithHeaders = True)
' Sanitize the supplied data ranges based on various criteria (see procedure's documentation)
If sanitizeDataRange(dataRangeMaster, rangeWithHeaders) = False Then GoTo rangeError
If sanitizeDataRange(dataRangeNew, rangeWithHeaders) = False Then GoTo rangeError
' Declaring counters for the final report's updated and appended records respectively
Dim updatedRecords As Integer: updatedRecords = 0
Dim appendedRecords As Integer: appendedRecords = 0
' Declaring the temporary variables which hold intermediate results during the for-loop
Dim updatableMasterRefCell As Range, currentRowIndex As Integer, updatableRowMaster As Range
For currentRowIndex = 1 To dataRangeNew.Rows.Count
' search the master's unique references (refColMaster range) for the current reference
' from dataRangeNew (refcolNew range)
Set updatableMasterRefCell = dataRangeMaster.Columns(refColIndexMaster).Find( _
what:=dataRangeNew.Cells(currentRowIndex, refColIndexNew).Value, _
lookat:=xlWhole, searchorder:=xlByRows, searchDirection:=xlNext)
' perform a check to see if the search has returned a valid range reference in updatableMasterRefCell
' if it is found empty (the reference value in refCellNew is unique to masterDataRange)
If updatableMasterRefCell Is Nothing Then
Call appendRecord(dataRangeNew.Rows(currentRowIndex), dataRangeMaster, colorAlertOption)
appendedRecords = appendedRecords + 1
'ReDim Preserve appendableRowIndices(appendedRecords)
'appendableRowIndices(appendedRecords) = currentRowIndex
Else
Set updatableRowMaster = Intersect(dataRangeMaster, updatableMasterRefCell.EntireRow)
Call updateRecord(dataRangeNew.Rows(currentRowIndex), updatableRowMaster, colorAlertOption)
updatedRecords = updatedRecords + 1
End If
Next currentRowIndex
' output an informative dialog to the user
Dim msg As String
msg = _
"sheet name: " & dataRangeMaster.Parent.Name & vbCrLf & _
"records updated: " & updatedRecords & vbCrLf & _
"records appended: " & appendedRecords
MsgBox msg, vbOKOnly, "--+ Update report +--"
Exit Sub
rangeError:
MsgBox "Either range argument is too small to operate on!", vbExclamation, "Argument Error"
End Sub
Sub appendRecord(ByVal recordRowSource As Range, ByRef dataRangeTarget As Range, Optional ByVal colorAlertOption As Boolean = True)
Dim appendedRowTarget As Range
Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count + 1)
Set appendedRowTarget = dataRangeTarget.Rows(dataRangeTarget.Rows.Count)
appendedRowTarget.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove
Set appendedRowTarget = appendedRowTarget.Offset(-1, 0)
' resize datarangetarget to -1 row (because cells' shifting incurred a +1 row to dataRangeTarget)
Set dataRangeTarget = dataRangeTarget.Resize(Rowsize:=dataRangeTarget.Rows.Count - 1)
recordRowSource.Copy appendedRowTarget
If colorAlertOption = True Then
' fills the cells of the newly appended row with lightgreen color
appendedRowTarget.Interior.color = RGB(156, 244, 164)
End If
End Sub
Sub updateRecord(ByVal recordRowSource As Range, ByVal updatableRowTarget As Range, Optional ByVal colorAlertOption As Boolean = True)
recordRowSource.Copy updatableRowTarget
If colorAlertOption = True Then
' fills the cells of the updated row with lightblue color
updatableRowTarget.Interior.color = RGB(164, 189, 249)
End If
End Sub
Private Function sanitizeDataRange(ByRef target As Range, ByVal rangeWithHeaders As Boolean) As Boolean
' if data range comprises only 1 cell then try to expand the range to currentRegion
' (all neighbouring cells until the selection reaches boundaries of blank rows or columns)
If target.Cells.Count = 1 Then
Set target = target.CurrentRegion
End If
' remove headers from data ranges if flag RangeWithHeaders is true
If (rangeWithHeaders) Then
If (target.Rows.Count >= 2) Then
Set target = target.Offset(1, 0).Resize(Rowsize:=(target.Rows.Count - 1))
Else
sanitizeDataRange = False
End If
End If
sanitizeDataRange = IIf((target.Rows.Count >= 1), True, False)
End Function
The results of a simple execution on your example gave the expected results, as you can see in the attached picture. There is even a dialogue with a brief report on the accomplished operations.
You haven't got much of a start. Will this outline get you started?
open all 3 workbooks
for masterrow = beginrow to endrow
if match in newsheet then
updaterow = newrow
else
updaterow = masterrow
end if
next masterrow
' now pick up unmatched newrows
for newrow = beginrow to endrow
if not match in updatesheet then
updaterow = newrow
end if
next newrow
EDIT: CodeVortex did the whole thing. My outline was flawed.
open both workbooks
appendrow = endrow of mastersheet
for newrow = beginrow to endrow
if match in mastersheet then
update masterrow
else
append into appendrow
appendrow = appendrow + 1
end if
next newrow