S
sbitaxi
Hello,
I have a macro that I have been using successfully for a couple of
months now that has suddenly stopped working. There are two Range
Objects that I have been using through it - FoundCell and MyCell.
About halfway through the code, they stop working and it throws a 424
error.
This is the statement where it fails. Following this is my entire code
up until this statement. I don't understand why they both fail to
continue functioning.
I appreciate any of your feedback.
Steven
Set FoundCell = SrcHdrRng.Find(What:="First Name", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Sub ArtezReport()
'Created by Steven Bitaxi for the Kidney Foundation of Canada. This
macro creates the donation/registration
'transaction report for a 1 month period, defined by the user.
'*Source
Dim SrcBk As Workbook 'Source Workbook
Dim SrcWS As Worksheet 'Source Worksheet
Dim SrcRng As Range 'A range value used in WS to identify
largest area of data
Dim SrcEntRng As Range 'Entire range in SrcWS
Dim SrcHdrRng As Range 'Range containing SrcWS header row
Dim SrcLast As Integer 'Last row of data in WS
Dim ThisWS As Worksheet
'*Destination
Dim DestBk As Workbook 'Destination Workbook
Dim DestWS As Worksheet 'Destination Worksheet
Dim DestCols As Long 'Column count in DestBk
Dim DestEmail As Range 'Email field in DestBk
Dim DestRng As Range 'Range in DestBk
Dim DestEntRng As Range 'Entire range in DestWS
Dim DestHdrRng As Range 'DestWS Header Row
Dim DestLast As Integer 'Last row of data in DestBk
Dim DestLastCol As String 'Last Column of data in DestBk
Dim DestRptCols As Variant 'Header now names for DestWS
Dim RegBk As Workbook 'Workbook for Registrations
Dim DonBk As Workbook 'Workbook for donations
Dim BookAndType As Variant 'Array for workbook splitting
Dim BAT As Long
'*Report date range configuration
Dim RptDate As Date 'Report start date
Dim EndRptDate As Date 'Report end date
Dim RptYear As Integer 'Report Year
Dim RptMth As Integer 'Report Month
Dim Response 'Input box response field
'*Macro variables
Dim DateFld As Variant 'Fields in workbook containing dates
and times to be parsed into two columns
Dim MyCell As Range 'Variable used in many finds/replaces
and filters
Dim RcdType As Variant '
Dim FoundCell As Range 'Variable used in finds
Dim RptCols As Variant 'Report field columns for export to
final report
Dim FirstCol As Range
Dim SecCol As Range
Dim Data As String
Dim ColOffset As Integer
'*Fixed Fields
Dim DonDte As Integer 'Donation Date field
Dim RegDte As Integer 'Registration date field
Dim FNm As String 'First Name Field
Dim HAdd As String 'Home Address field
Dim BAdd As String 'Business Address field
Dim PrefBAdd As String 'Business Address Preferred Field
Dim PaymentAmt As Range 'Payment amount field
Dim Email As Range 'Email Field range
Dim DonTtl As String 'Total value of donations
Dim RegTtl As String 'Total value of registrations
Dim FiltFields As Variant 'Array for SrcWS filters
Dim FltFlds As Long
'* To time macro
Dim Dtm1 As Date, Dtm2 As Date
'* Combine multiple files
Dim NmFiles As Long
Dim GetFile As String
Dim FilesLst As String
Dim FilesToOpen As Workbook
Dim i As Long
Dim ThisWB As Workbook
'Dim ThisWS As Worksheet
Dim Wkb As Workbook
Dim WS As Worksheet
Dim LastCell As Range
Dim ThisLast As Long
Dim Hdr As String
Dim SavePath As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Rng As Range
'************************************************************************************************************
'* Start timing macro duration
Dtm1 = Time
'* Prompt User for number of files to be combined in report
5 NmFiles = InputBox("How many files make up this report?",
"Files")
If NmFiles > 0 Then
Set SrcBk = Workbooks.Add
Set SrcWS = SrcBk.Sheets(1)
'* Disable Screen updating, calculations and anything else that might
slow down macro processing
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'* Generate file to be processed
i = 1
Do Until i > NmFiles
If i = 1 Then
Hdr = "A1:"
Else
Hdr = "A2:"
End If
MsgBox ("Please select file " & i)
GetFile = Application.GetOpenFilename()
Set FilesToOpen = Workbooks.Open(GetFile)
Set WS = FilesToOpen.Sheets(1)
Set LastCell = WS.Cells.SpecialCells
(xlCellTypeLastCell)
If LastCell.Value = "" And
LastCell.Address = Range("$A$1").Address Then
Else
SrcLast = LastRow(SrcWS)
WS.Range(Hdr &
LastCell.Address).Copy Destination:= _
SrcWS.Range("A" & (SrcLast + 1))
End If
i = i + 1
Application.CutCopyMode = False
FilesToOpen.Close
Loop
Else
MsgBox ("There must be at least one file. Please
select a file.")
GoTo 5
End If
With SrcWS
.Copy , SrcWS
.Name = "Full Export"
End With
Set SrcWS = SrcBk.Sheets(2)
SrcWS.Name = "Master"
Set LastCell = Nothing
Set WS = Nothing
Set FilesToOpen = Nothing
GetFile = vbNull
NmFiles = vbNull
'Fill in the path\folder where you want the new folder with the
files
'you can use also this "C:\Users\Ron\test"
SavePath = "Y:\Communications\Online Fundraising\Donor Reports\" &
_
Year(Date) & "\" & MonthName(Month(Date) - 1) & " " &
Year(Date) & "\"
'Add a slash at the end if the user forget it
If Right(SavePath, 1) <> "\" Then
SavePath = SavePath & "\"
End If
'Determine the Excel version and file extension/format
If Val(Application.VERSION) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If SrcBk.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'* Prompt User for Report Year
1 RptYear = InputBox("Indicate the year for this report:",
"Year", Year(Date))
'* Prompt User for Report Month
RptMth = InputBox("Indicate the month for this report:",
"Month", Month(Date) - 1)
'* Verify Report period
Response = MsgBox("You selected " & RptMth & "/" & RptYear
& ". Is this correct?", _
vbYesNo, "Verification")
If Response = vbNo Then GoTo 1
'* Set Report Dates
RptDate = RptMth & "/" & RptYear
EndRptDate = RptMth + 1 & "/" & RptYear
Response = vbNull
'* Declare Source Variables variables
SrcLast = LastRow(SrcWS)
Set SrcRng = Range("2:" & SrcLast)
Set SrcEntRng = Range("1:" & SrcLast)
Set SrcHdrRng = Range("A1:" & (SrcWS.Cells(1, Columns.Count).End
(xlToLeft).Address))
SrcWS.Range("A1").Select
'* Set RegDte
Set MyCell = SrcHdrRng.Find
(What:="RegistrationDate", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
RegDte = (MyCell.Column)
'* Set PaymentAmt
Set MyCell = SrcHdrRng.Find(What:="PaymentAmount",
_
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Set PaymentAmt = Range(MyCell.Address, Cells(SrcLast, MyCell.Column))
'* Names header fields
RptCols = Array("HomeAddressLine1", "CCHolderName",
"CCTransactionID", "CCType", "HomeCity", _
"ConstituentID", "ConstituentType",
"HomeCountry", "DonationAmount", "DonationDate", _
"HomeEmailPermission", "PreferredLanguage",
"EventID", "FirstName", "HomeEmailAddress", _
"LastName", "LocationID", "PaymentMethod",
"HomePostalCode", "HomeProvince", _
"RegistrationFeeStatus",
"RegistrationFeeAmount", "TaxReceiptAmount", "TaxReceiptNumber", _
"TransactionID", "TransactionType")
For Each Thing In RptCols
Set FoundCell = SrcHdrRng.Find(What:=Thing, _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Select Case FoundCell.Value
Case "HomeAddressLine1"
FoundCell.Value = "Address"
HAdd = Range(FoundCell.Address, Cells
(SrcLast, FoundCell.Column)).Address
Case "CCHolderName"
FoundCell.Value = "CC Holder Name"
Case "CCTransactionID"
FoundCell.Value = "CC Trans ID"
Case "CCType"
FoundCell.Value = "CC Type"
Case "HomeCity"
FoundCell.Value = "City"
Case "ConstituentID"
FoundCell.Value = "Constit ID"
Case "ConstituentType"
FoundCell.Value = "Constit Type"
Case "HomeCountry"
FoundCell.Value = "Cntry"
Case "DonationAmount"
FoundCell.Value = "Amt"
Case "DonationDate"
FoundCell.Value = "Date"
DonDte = (FoundCell.Column)
Case "HomeEmailPermission"
FoundCell.Value = "Email Y/N"
Case "PreferredLanguage"
FoundCell.Value = "Eng/Fr"
Case "EventID"
FoundCell.Value = "Event ID"
Case "FirstName"
FoundCell.Value = "First Name"
FNm = Range(FoundCell.Address, Cells
(SrcLast, FoundCell.Column)).Address
Case "HomeEmailAddress"
FoundCell.Value = "Email"
Case "LastName"
FoundCell.Value = "Last Name"
Case "LocationID"
FoundCell.Value = "Location"
NmFiles = FoundCell.Column
Case "PaymentMethod"
FoundCell.Value = "Pmt Mthd"
Case "HomePostalCode"
FoundCell.Value = "PC"
Case "HomeProvince"
FoundCell.Value = "Prov"
Case "RegistrationFeeStatus"
FoundCell.Value = "Reg Fee"
Case "RegistrationFeeAmount"
FoundCell.Value = "Reg Fee Amt"
Case "TaxReceiptAmount"
FoundCell.Value = "Tax Rcpt Amt"
Case "TaxReceiptNumber"
FoundCell.Value = "Tax Rcpt Num"
Case "TransactionID"
FoundCell.Value = "Trans ID"
Case "TransactionType"
FoundCell.Value = "Trans Type"
End Select
Next
RptCols = vbNull
'* Removes Tribute, Failed Transactions, registrations that have no
applicable fees
On Error GoTo ErrorHandler
FiltFields = Array(Array("Event ID", "=*Tribute*", "", "Tribute"), _
Array("PaymentStatus", "<>Succeeded", "",
"FailedPayments"), _
Array("Trans Type", "=*Tribute*", "",
"Tribute2"), _
Array("Reg Fee", "=Waived", "=Cancelled",
"Waived_Cancelled"))
For FltFlds = LBound(FiltFields, 1) To UBound(FiltFields, 1)
Set FoundCell = SrcHdrRng.Find(What:=FiltFields(FltFlds)(0), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Call WSFilt(SrcWS, SrcEntRng, SrcRng, FiltFields(FltFlds)(1), _
FiltFields(FltFlds)(2), FoundCell.Column, FiltFields
(FltFlds)(3))
Next FltFlds
On Error GoTo ErrorHandler
SrcLast = LastRow(SrcWS)
With SrcWS
'* Insert column for Time stamp and separate Time from Date
DateFld = Array(DonDte, RegDte)
For Each Thing In DateFld
Columns(Thing + 1).Insert Shift:=xlRight
Application.DisplayAlerts = False
With Columns(Thing)
.TextToColumns Destination:=Columns
(Thing), Other:=True, OtherChar:="T"
.NumberFormat = "m/d/yyyy"
End With
Application.DisplayAlerts = True
'* Remove records outside of report date range
SrcEntRng.AutoFilter Field:=Thing, Criteria1:="<" & RptDate, _
Operator:=xlOr, Criteria2:=">=" & EndRptDate
Set Rng = Union(IIf(Rng Is Nothing,
SrcRng.Cells.SpecialCells(xlVisible), Rng), _
SrcRng.Cells.SpecialCells(xlVisible))
.AutoFilterMode = False
If Thing = RegDte Then GoTo 10 'Otherwise you will need
more lines of code to deal with both instances
SrcEntRng.AutoFilter Field:=Thing, Criteria1:="="
SrcEntRng.AutoFilter Field:=RegDte, Criteria1:="="
On Error GoTo 10
Set Rng = Union(IIf(Rng Is Nothing,
SrcRng.Cells.SpecialCells(xlVisible), Rng), _
SrcRng.Cells.SpecialCells(xlVisible))
10 .AutoFilterMode = False
'* Labels field headers
If Thing = DonDte Then
Cells(1, Thing).Value = "Date"
DonDte = DonDte + 1
Else
Cells(1, Thing).Value = "Registration Date"
End If
Next
On Error GoTo ErrorHandler
GetFile = "OutsideDateRange"
Set ThisWS = Worksheets.Add
ThisWS.Name = GetFile
SrcWS.Activate
SrcWS.Range("1:1").Copy Destination:=ThisWS.Range("A1")
If Not Rng Is Nothing Then Rng.EntireRow.Copy
Destination:=ThisWS.Range("A2"): _
Rng.EntireRow.Delete: Set Rng = Nothing
SrcLast = LastRow(SrcWS)
'Set MyCell = Nothing
'Set Rng = Nothing
'* Combines Registration Date and Donation Date into one field
SrcEntRng.AutoFilter Field:=DonDte, Criteria1:="="
If SrcWS.Cells(Rows.Count, "A").End(xlUp).Row < 2 Then
GoTo 11
For Each MyCell In Range(Cells(2, DonDte), Cells(SrcLast,
DonDte)).SpecialCells(xlVisible)
MyCell.Value = Cells(MyCell.Row, RegDte).Value
Next MyCell
11 .AutoFilterMode = False
Set Rng = Nothing
On Error GoTo ErrorHandler
'* Combines Registration Date and Donation Date into one field
Set FoundCell = SrcHdrRng.Find(What:="Amt", _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Set Rng = SrcHdrRng.Find(What:="Reg Fee Amt", _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
SrcEntRng.AutoFilter Field:=FoundCell.Column,
Criteria1:="="
If SrcWS.Cells(Rows.Count, "A").End(xlUp).Row < 2 Then
GoTo 12
For Each MyCell In Range(Cells(2, FoundCell.Column),
Cells(SrcLast, FoundCell.Column)) _
.SpecialCells
(xlVisible)
MyCell.Value = Cells(MyCell.Row, Rng.Column).Value
Next MyCell
FoundCell.Value = "Amt"
Set Rng = Nothing
12 SrcWS.AutoFilterMode = False
'* Removes Duplicate transactions
On Error GoTo ErrorHandler
SrcRng.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=False,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
SrcLast = LastRow(SrcWS)
Set FoundCell = SrcHdrRng.Find(What:="Trans ID", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
For Each MyCell In Range(Cells(2, FoundCell.Column), Cells
(SrcLast, FoundCell.Column)) _
.SpecialCells
(xlVisible)
If MyCell.Value = MyCell.Offset(1, 0).Value Then
MyCell = MyCell.Offset(1, 0)
Set Rng = Union(IIf(Rng Is Nothing, MyCell,
Rng), MyCell)
End If
Next
GetFile = "Duplicates"
Set ThisWS = Worksheets.Add
ThisWS.Name = GetFile
SrcWS.Activate
SrcWS.Range("1:1").Copy Destination:=ThisWS.Range("A1")
If Not Rng Is Nothing Then Rng.EntireRow.Copy
Destination:=ThisWS.Range("A2"): _
Rng.EntireRow.Delete: Set Rng = Nothing
Sheets(GetFile).Range("1:1").Copy
Range("1:1").Rows.Insert Shift:=xlDown ', CopyOrigin:=Sheets
(GetFile).Range("1:1")
SrcLast = LastRow(SrcWS)
End With
'* Concatenates First Name and Middle Name
With SrcWS
'* Set FNm
Set FoundCell = SrcHdrRng.Find(What:="First Name", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
I have a macro that I have been using successfully for a couple of
months now that has suddenly stopped working. There are two Range
Objects that I have been using through it - FoundCell and MyCell.
About halfway through the code, they stop working and it throws a 424
error.
This is the statement where it fails. Following this is my entire code
up until this statement. I don't understand why they both fail to
continue functioning.
I appreciate any of your feedback.
Steven
Set FoundCell = SrcHdrRng.Find(What:="First Name", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Sub ArtezReport()
'Created by Steven Bitaxi for the Kidney Foundation of Canada. This
macro creates the donation/registration
'transaction report for a 1 month period, defined by the user.
'*Source
Dim SrcBk As Workbook 'Source Workbook
Dim SrcWS As Worksheet 'Source Worksheet
Dim SrcRng As Range 'A range value used in WS to identify
largest area of data
Dim SrcEntRng As Range 'Entire range in SrcWS
Dim SrcHdrRng As Range 'Range containing SrcWS header row
Dim SrcLast As Integer 'Last row of data in WS
Dim ThisWS As Worksheet
'*Destination
Dim DestBk As Workbook 'Destination Workbook
Dim DestWS As Worksheet 'Destination Worksheet
Dim DestCols As Long 'Column count in DestBk
Dim DestEmail As Range 'Email field in DestBk
Dim DestRng As Range 'Range in DestBk
Dim DestEntRng As Range 'Entire range in DestWS
Dim DestHdrRng As Range 'DestWS Header Row
Dim DestLast As Integer 'Last row of data in DestBk
Dim DestLastCol As String 'Last Column of data in DestBk
Dim DestRptCols As Variant 'Header now names for DestWS
Dim RegBk As Workbook 'Workbook for Registrations
Dim DonBk As Workbook 'Workbook for donations
Dim BookAndType As Variant 'Array for workbook splitting
Dim BAT As Long
'*Report date range configuration
Dim RptDate As Date 'Report start date
Dim EndRptDate As Date 'Report end date
Dim RptYear As Integer 'Report Year
Dim RptMth As Integer 'Report Month
Dim Response 'Input box response field
'*Macro variables
Dim DateFld As Variant 'Fields in workbook containing dates
and times to be parsed into two columns
Dim MyCell As Range 'Variable used in many finds/replaces
and filters
Dim RcdType As Variant '
Dim FoundCell As Range 'Variable used in finds
Dim RptCols As Variant 'Report field columns for export to
final report
Dim FirstCol As Range
Dim SecCol As Range
Dim Data As String
Dim ColOffset As Integer
'*Fixed Fields
Dim DonDte As Integer 'Donation Date field
Dim RegDte As Integer 'Registration date field
Dim FNm As String 'First Name Field
Dim HAdd As String 'Home Address field
Dim BAdd As String 'Business Address field
Dim PrefBAdd As String 'Business Address Preferred Field
Dim PaymentAmt As Range 'Payment amount field
Dim Email As Range 'Email Field range
Dim DonTtl As String 'Total value of donations
Dim RegTtl As String 'Total value of registrations
Dim FiltFields As Variant 'Array for SrcWS filters
Dim FltFlds As Long
'* To time macro
Dim Dtm1 As Date, Dtm2 As Date
'* Combine multiple files
Dim NmFiles As Long
Dim GetFile As String
Dim FilesLst As String
Dim FilesToOpen As Workbook
Dim i As Long
Dim ThisWB As Workbook
'Dim ThisWS As Worksheet
Dim Wkb As Workbook
Dim WS As Worksheet
Dim LastCell As Range
Dim ThisLast As Long
Dim Hdr As String
Dim SavePath As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Rng As Range
'************************************************************************************************************
'* Start timing macro duration
Dtm1 = Time
'* Prompt User for number of files to be combined in report
5 NmFiles = InputBox("How many files make up this report?",
"Files")
If NmFiles > 0 Then
Set SrcBk = Workbooks.Add
Set SrcWS = SrcBk.Sheets(1)
'* Disable Screen updating, calculations and anything else that might
slow down macro processing
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'* Generate file to be processed
i = 1
Do Until i > NmFiles
If i = 1 Then
Hdr = "A1:"
Else
Hdr = "A2:"
End If
MsgBox ("Please select file " & i)
GetFile = Application.GetOpenFilename()
Set FilesToOpen = Workbooks.Open(GetFile)
Set WS = FilesToOpen.Sheets(1)
Set LastCell = WS.Cells.SpecialCells
(xlCellTypeLastCell)
If LastCell.Value = "" And
LastCell.Address = Range("$A$1").Address Then
Else
SrcLast = LastRow(SrcWS)
WS.Range(Hdr &
LastCell.Address).Copy Destination:= _
SrcWS.Range("A" & (SrcLast + 1))
End If
i = i + 1
Application.CutCopyMode = False
FilesToOpen.Close
Loop
Else
MsgBox ("There must be at least one file. Please
select a file.")
GoTo 5
End If
With SrcWS
.Copy , SrcWS
.Name = "Full Export"
End With
Set SrcWS = SrcBk.Sheets(2)
SrcWS.Name = "Master"
Set LastCell = Nothing
Set WS = Nothing
Set FilesToOpen = Nothing
GetFile = vbNull
NmFiles = vbNull
'Fill in the path\folder where you want the new folder with the
files
'you can use also this "C:\Users\Ron\test"
SavePath = "Y:\Communications\Online Fundraising\Donor Reports\" &
_
Year(Date) & "\" & MonthName(Month(Date) - 1) & " " &
Year(Date) & "\"
'Add a slash at the end if the user forget it
If Right(SavePath, 1) <> "\" Then
SavePath = SavePath & "\"
End If
'Determine the Excel version and file extension/format
If Val(Application.VERSION) < 12 Then
'You use Excel 97-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007
If SrcBk.Parent.FileFormat = 56 Then
FileExtStr = ".xls": FileFormatNum = 56
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
End If
'* Prompt User for Report Year
1 RptYear = InputBox("Indicate the year for this report:",
"Year", Year(Date))
'* Prompt User for Report Month
RptMth = InputBox("Indicate the month for this report:",
"Month", Month(Date) - 1)
'* Verify Report period
Response = MsgBox("You selected " & RptMth & "/" & RptYear
& ". Is this correct?", _
vbYesNo, "Verification")
If Response = vbNo Then GoTo 1
'* Set Report Dates
RptDate = RptMth & "/" & RptYear
EndRptDate = RptMth + 1 & "/" & RptYear
Response = vbNull
'* Declare Source Variables variables
SrcLast = LastRow(SrcWS)
Set SrcRng = Range("2:" & SrcLast)
Set SrcEntRng = Range("1:" & SrcLast)
Set SrcHdrRng = Range("A1:" & (SrcWS.Cells(1, Columns.Count).End
(xlToLeft).Address))
SrcWS.Range("A1").Select
'* Set RegDte
Set MyCell = SrcHdrRng.Find
(What:="RegistrationDate", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
RegDte = (MyCell.Column)
'* Set PaymentAmt
Set MyCell = SrcHdrRng.Find(What:="PaymentAmount",
_
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Set PaymentAmt = Range(MyCell.Address, Cells(SrcLast, MyCell.Column))
'* Names header fields
RptCols = Array("HomeAddressLine1", "CCHolderName",
"CCTransactionID", "CCType", "HomeCity", _
"ConstituentID", "ConstituentType",
"HomeCountry", "DonationAmount", "DonationDate", _
"HomeEmailPermission", "PreferredLanguage",
"EventID", "FirstName", "HomeEmailAddress", _
"LastName", "LocationID", "PaymentMethod",
"HomePostalCode", "HomeProvince", _
"RegistrationFeeStatus",
"RegistrationFeeAmount", "TaxReceiptAmount", "TaxReceiptNumber", _
"TransactionID", "TransactionType")
For Each Thing In RptCols
Set FoundCell = SrcHdrRng.Find(What:=Thing, _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Select Case FoundCell.Value
Case "HomeAddressLine1"
FoundCell.Value = "Address"
HAdd = Range(FoundCell.Address, Cells
(SrcLast, FoundCell.Column)).Address
Case "CCHolderName"
FoundCell.Value = "CC Holder Name"
Case "CCTransactionID"
FoundCell.Value = "CC Trans ID"
Case "CCType"
FoundCell.Value = "CC Type"
Case "HomeCity"
FoundCell.Value = "City"
Case "ConstituentID"
FoundCell.Value = "Constit ID"
Case "ConstituentType"
FoundCell.Value = "Constit Type"
Case "HomeCountry"
FoundCell.Value = "Cntry"
Case "DonationAmount"
FoundCell.Value = "Amt"
Case "DonationDate"
FoundCell.Value = "Date"
DonDte = (FoundCell.Column)
Case "HomeEmailPermission"
FoundCell.Value = "Email Y/N"
Case "PreferredLanguage"
FoundCell.Value = "Eng/Fr"
Case "EventID"
FoundCell.Value = "Event ID"
Case "FirstName"
FoundCell.Value = "First Name"
FNm = Range(FoundCell.Address, Cells
(SrcLast, FoundCell.Column)).Address
Case "HomeEmailAddress"
FoundCell.Value = "Email"
Case "LastName"
FoundCell.Value = "Last Name"
Case "LocationID"
FoundCell.Value = "Location"
NmFiles = FoundCell.Column
Case "PaymentMethod"
FoundCell.Value = "Pmt Mthd"
Case "HomePostalCode"
FoundCell.Value = "PC"
Case "HomeProvince"
FoundCell.Value = "Prov"
Case "RegistrationFeeStatus"
FoundCell.Value = "Reg Fee"
Case "RegistrationFeeAmount"
FoundCell.Value = "Reg Fee Amt"
Case "TaxReceiptAmount"
FoundCell.Value = "Tax Rcpt Amt"
Case "TaxReceiptNumber"
FoundCell.Value = "Tax Rcpt Num"
Case "TransactionID"
FoundCell.Value = "Trans ID"
Case "TransactionType"
FoundCell.Value = "Trans Type"
End Select
Next
RptCols = vbNull
'* Removes Tribute, Failed Transactions, registrations that have no
applicable fees
On Error GoTo ErrorHandler
FiltFields = Array(Array("Event ID", "=*Tribute*", "", "Tribute"), _
Array("PaymentStatus", "<>Succeeded", "",
"FailedPayments"), _
Array("Trans Type", "=*Tribute*", "",
"Tribute2"), _
Array("Reg Fee", "=Waived", "=Cancelled",
"Waived_Cancelled"))
For FltFlds = LBound(FiltFields, 1) To UBound(FiltFields, 1)
Set FoundCell = SrcHdrRng.Find(What:=FiltFields(FltFlds)(0), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Call WSFilt(SrcWS, SrcEntRng, SrcRng, FiltFields(FltFlds)(1), _
FiltFields(FltFlds)(2), FoundCell.Column, FiltFields
(FltFlds)(3))
Next FltFlds
On Error GoTo ErrorHandler
SrcLast = LastRow(SrcWS)
With SrcWS
'* Insert column for Time stamp and separate Time from Date
DateFld = Array(DonDte, RegDte)
For Each Thing In DateFld
Columns(Thing + 1).Insert Shift:=xlRight
Application.DisplayAlerts = False
With Columns(Thing)
.TextToColumns Destination:=Columns
(Thing), Other:=True, OtherChar:="T"
.NumberFormat = "m/d/yyyy"
End With
Application.DisplayAlerts = True
'* Remove records outside of report date range
SrcEntRng.AutoFilter Field:=Thing, Criteria1:="<" & RptDate, _
Operator:=xlOr, Criteria2:=">=" & EndRptDate
Set Rng = Union(IIf(Rng Is Nothing,
SrcRng.Cells.SpecialCells(xlVisible), Rng), _
SrcRng.Cells.SpecialCells(xlVisible))
.AutoFilterMode = False
If Thing = RegDte Then GoTo 10 'Otherwise you will need
more lines of code to deal with both instances
SrcEntRng.AutoFilter Field:=Thing, Criteria1:="="
SrcEntRng.AutoFilter Field:=RegDte, Criteria1:="="
On Error GoTo 10
Set Rng = Union(IIf(Rng Is Nothing,
SrcRng.Cells.SpecialCells(xlVisible), Rng), _
SrcRng.Cells.SpecialCells(xlVisible))
10 .AutoFilterMode = False
'* Labels field headers
If Thing = DonDte Then
Cells(1, Thing).Value = "Date"
DonDte = DonDte + 1
Else
Cells(1, Thing).Value = "Registration Date"
End If
Next
On Error GoTo ErrorHandler
GetFile = "OutsideDateRange"
Set ThisWS = Worksheets.Add
ThisWS.Name = GetFile
SrcWS.Activate
SrcWS.Range("1:1").Copy Destination:=ThisWS.Range("A1")
If Not Rng Is Nothing Then Rng.EntireRow.Copy
Destination:=ThisWS.Range("A2"): _
Rng.EntireRow.Delete: Set Rng = Nothing
SrcLast = LastRow(SrcWS)
'Set MyCell = Nothing
'Set Rng = Nothing
'* Combines Registration Date and Donation Date into one field
SrcEntRng.AutoFilter Field:=DonDte, Criteria1:="="
If SrcWS.Cells(Rows.Count, "A").End(xlUp).Row < 2 Then
GoTo 11
For Each MyCell In Range(Cells(2, DonDte), Cells(SrcLast,
DonDte)).SpecialCells(xlVisible)
MyCell.Value = Cells(MyCell.Row, RegDte).Value
Next MyCell
11 .AutoFilterMode = False
Set Rng = Nothing
On Error GoTo ErrorHandler
'* Combines Registration Date and Donation Date into one field
Set FoundCell = SrcHdrRng.Find(What:="Amt", _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
Set Rng = SrcHdrRng.Find(What:="Reg Fee Amt", _
Lookat:=xlWhole, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
SrcEntRng.AutoFilter Field:=FoundCell.Column,
Criteria1:="="
If SrcWS.Cells(Rows.Count, "A").End(xlUp).Row < 2 Then
GoTo 12
For Each MyCell In Range(Cells(2, FoundCell.Column),
Cells(SrcLast, FoundCell.Column)) _
.SpecialCells
(xlVisible)
MyCell.Value = Cells(MyCell.Row, Rng.Column).Value
Next MyCell
FoundCell.Value = "Amt"
Set Rng = Nothing
12 SrcWS.AutoFilterMode = False
'* Removes Duplicate transactions
On Error GoTo ErrorHandler
SrcRng.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=False,
_
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
_
DataOption1:=xlSortNormal
SrcLast = LastRow(SrcWS)
Set FoundCell = SrcHdrRng.Find(What:="Trans ID", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
For Each MyCell In Range(Cells(2, FoundCell.Column), Cells
(SrcLast, FoundCell.Column)) _
.SpecialCells
(xlVisible)
If MyCell.Value = MyCell.Offset(1, 0).Value Then
MyCell = MyCell.Offset(1, 0)
Set Rng = Union(IIf(Rng Is Nothing, MyCell,
Rng), MyCell)
End If
Next
GetFile = "Duplicates"
Set ThisWS = Worksheets.Add
ThisWS.Name = GetFile
SrcWS.Activate
SrcWS.Range("1:1").Copy Destination:=ThisWS.Range("A1")
If Not Rng Is Nothing Then Rng.EntireRow.Copy
Destination:=ThisWS.Range("A2"): _
Rng.EntireRow.Delete: Set Rng = Nothing
Sheets(GetFile).Range("1:1").Copy
Range("1:1").Rows.Insert Shift:=xlDown ', CopyOrigin:=Sheets
(GetFile).Range("1:1")
SrcLast = LastRow(SrcWS)
End With
'* Concatenates First Name and Middle Name
With SrcWS
'* Set FNm
Set FoundCell = SrcHdrRng.Find(What:="First Name", _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)