S
sbitaxi
Hello:
I've been working on the following code to set up a report by removing
data outside of the date range, and then copying the required columns
to a new workbook and formatting the new book. For the past few days
it has worked fine, suddenly it started to lock up when I called on
the LastRow UDF to determine what the new last row was after removing
all the data before copying to the new workbook.
For some reason, it has stopped working. If I put a watch on the step
and step through that segment manually, it works fine, but not when I
run it straight through. I've copied all the code upto and including
the step that fails. Any help is immensely appreciated!
Steven
Function LastRow(SH As Worksheet)
On Error Resume Next
LastRow = SH.Cells.Find(What:="*", _
After:=SH.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(SH As Worksheet)
On Error Resume Next
LastCol = SH.Cells.Find(What:="*", _
After:=SH.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub ArtezReport()
'*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 SrcHdrRng As Range 'Range containing SrcWS header row
Dim SrcLast As Integer 'Last row of data in WS
'*Destination
Dim DestBk As Workbook 'Destination Workbook
Dim DestWS As Worksheet 'Destination Worksheet
Dim DestCols As Integer 'Column count in DestBk
Dim DestEmail As Range 'Email field in DestBk
Dim DestRng As Range 'Range in DestBk
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
'*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
'*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 Email As Range 'Email Field range
Dim DonTtl As String 'Total value of donations
Dim RegTtl As String 'Total value of registrations
'* To time macro
Dim dtm1 As Date, dtm2 As Date
'************************************************************************************************************
'* Start timing macro duration
dtm1 = Time
'* 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
'* Disable Screen updating, calculations and anything else that might
slow down macro processing
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'* Declare Source Variables variables
Set SourceBk = ActiveWorkbook
Set SrcWS = ActiveSheet
SrcLast = LastRow(SrcWS)
Set SrcRng = Range("2:" & SrcLast)
Set SrcHdrRng = Range("A1:" & (ActiveSheet.Cells(1,
Columns.Count).End(xlToLeft).Address))
SrcWS.Range("A1").Select
'* Set RegDte
Set MyCell =
SrcHdrRng.Find(What:="RegistrationDate")
RegDte = (MyCell.Column)
'* Set FNm
Set MyCell =
SrcHdrRng.Find(What:="FirstName").EntireColumn
FNm = (MyCell.EntireColumn.Address)
'* Set BAdd
Set MyCell =
SrcHdrRng.Find(What:="BusinessAddressLine1")
BAdd = (MyCell.EntireColumn.Address)
'* Set PrefBAdd
Set MyCell =
SrcHdrRng.Find(What:="BusinessPreferredAddress")
PrefBAdd = (MyCell.EntireColumn.Address)
'* 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)
Select Case FoundCell.Value
Case "HomeAddressLine1"
FoundCell.Value = "Address Line1"
HAdd =
(FoundCell.EntireColumn.Address)
Case "CCHolderName"
FoundCell.Value = "CC Holder Name"
Case "CCTransactionID"
FoundCell.Value = "CC Transaction 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 = "Country"
Case "DonationAmount"
FoundCell.Value = "Donation Amount"
Case "DonationDate"
FoundCell.Value = "Donation 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"
Case "HomeEmailAddress"
FoundCell.Value = "Home Email"
Case "LastName"
FoundCell.Value = "Last Name"
Case "LocationID"
FoundCell.Value = "Location ID"
Case "PaymentMethod"
FoundCell.Value = "Payment Method"
Case "HomePostalCode"
FoundCell.Value = "Postal Code"
Case "HomeProvince"
FoundCell.Value = "Prov"
Case "RegistrationFeeStatus"
FoundCell.Value = "Registration Fee"
Case "RegistrationFeeAmount"
FoundCell.Value = "Registration Fee
Amount"
Case "TaxReceiptAmount"
FoundCell.Value = "Tax Receipt Amount"
Case "TaxReceiptNumber"
FoundCell.Value = "Tax Receipt Number"
Case "TransactionID"
FoundCell.Value = "Trans ID"
Case "TransactionType"
FoundCell.Value = "Trans Type"
End Select
Next
'* Removes Tribute and records with no fee associated
RcdType = Array("TributeCardRecipient") '"Tribute") ',
"NotApplicable")
For Each Thing In RcdType
Do
SrcRng.Select
Set FoundCell = SrcRng.Find(What:=Thing)
If FoundCell Is Nothing Then
GoTo 2
Else
SrcRng.Find(What:=Thing).Activate
ActiveCell.EntireRow.Delete
End If
Loop
2 Next
'* Concatenates First Name and Middle Name
For Each MyCell In Range(FNm)
If MyCell.Row > 1 Then
MyCell.Formula = MyCell.Value & " " _
& MyCell.Offset(0, 1).Value
MyCell.Formula = LTrim(MyCell.Formula)
MyCell.Formula = RTrim(MyCell.Formula)
End If
Next
'*Replaces Home address with preferred business address
For Each MyCell In Range(PrefBAdd)
If MyCell.Value = "y" Then
MyCell.Offset(0, -13).Value =
Intersect(Rows(MyCell.Row), Columns(BAdd)).Value _
& " " & Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 1)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 2)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 3)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 4)).Value
MyCell.Offset(0, -8).Value =
MyCell.Offset(0, 6).Value
MyCell.Offset(0, -7).Value =
MyCell.Offset(0, 7).Value
MyCell.Offset(0, -6).Value =
MyCell.Offset(0, 8).Value
MyCell.Offset(0, -5).Value =
MyCell.Offset(0, 9).Value
End If
Next
'*Concatenates Home into one column for each
For Each MyCell In Range(HAdd)
If Not MyCell.Value = "" Then
If MyCell.Row > 1 Then
MyCell.Formula = MyCell.Value & " " _
& MyCell.Offset(0, 1).Value & " " _
& MyCell.Offset(0, 2).Value & " " _
& MyCell.Offset(0, 3).Value & " " _
& MyCell.Offset(0, 4).Value
MyCell.Formula = LTrim(MyCell.Formula)
MyCell.Formula = RTrim(MyCell.Formula)
End If
End If
Next
'* 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
Columns(Thing).Select
Application.DisplayAlerts = False
With Selection.Columns
.TextToColumns
Destination:=Columns(Thing), Other:=True, OtherChar:="T"
.NumberFormat = "m/d/yyyy"
End With
Application.DisplayAlerts = True
'* Remove records outside of report date range
SrcRng.AutoFilter Field:=Thing, Criteria1:="<"
& RptDate
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
SrcRng.AutoFilter Field:=Thing,
Criteria1:=">=" & EndRptDate
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
If Thing = DonDte Then
Cells(1, Thing).Value = "Donation Date"
Else
Cells(1, Thing).Value = "Registration Date"
End If
Next
Set MyCell = SrcHdrRng.Find("PaymentStatus").Columns
SrcRng.AutoFilter Field:=MyCell.Column,
Criteria1:="*Failed*"
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
SrcLast = LastRow(SrcWS)
I've been working on the following code to set up a report by removing
data outside of the date range, and then copying the required columns
to a new workbook and formatting the new book. For the past few days
it has worked fine, suddenly it started to lock up when I called on
the LastRow UDF to determine what the new last row was after removing
all the data before copying to the new workbook.
For some reason, it has stopped working. If I put a watch on the step
and step through that segment manually, it works fine, but not when I
run it straight through. I've copied all the code upto and including
the step that fails. Any help is immensely appreciated!
Steven
Function LastRow(SH As Worksheet)
On Error Resume Next
LastRow = SH.Cells.Find(What:="*", _
After:=SH.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(SH As Worksheet)
On Error Resume Next
LastCol = SH.Cells.Find(What:="*", _
After:=SH.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
Sub ArtezReport()
'*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 SrcHdrRng As Range 'Range containing SrcWS header row
Dim SrcLast As Integer 'Last row of data in WS
'*Destination
Dim DestBk As Workbook 'Destination Workbook
Dim DestWS As Worksheet 'Destination Worksheet
Dim DestCols As Integer 'Column count in DestBk
Dim DestEmail As Range 'Email field in DestBk
Dim DestRng As Range 'Range in DestBk
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
'*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
'*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 Email As Range 'Email Field range
Dim DonTtl As String 'Total value of donations
Dim RegTtl As String 'Total value of registrations
'* To time macro
Dim dtm1 As Date, dtm2 As Date
'************************************************************************************************************
'* Start timing macro duration
dtm1 = Time
'* 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
'* Disable Screen updating, calculations and anything else that might
slow down macro processing
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
'* Declare Source Variables variables
Set SourceBk = ActiveWorkbook
Set SrcWS = ActiveSheet
SrcLast = LastRow(SrcWS)
Set SrcRng = Range("2:" & SrcLast)
Set SrcHdrRng = Range("A1:" & (ActiveSheet.Cells(1,
Columns.Count).End(xlToLeft).Address))
SrcWS.Range("A1").Select
'* Set RegDte
Set MyCell =
SrcHdrRng.Find(What:="RegistrationDate")
RegDte = (MyCell.Column)
'* Set FNm
Set MyCell =
SrcHdrRng.Find(What:="FirstName").EntireColumn
FNm = (MyCell.EntireColumn.Address)
'* Set BAdd
Set MyCell =
SrcHdrRng.Find(What:="BusinessAddressLine1")
BAdd = (MyCell.EntireColumn.Address)
'* Set PrefBAdd
Set MyCell =
SrcHdrRng.Find(What:="BusinessPreferredAddress")
PrefBAdd = (MyCell.EntireColumn.Address)
'* 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)
Select Case FoundCell.Value
Case "HomeAddressLine1"
FoundCell.Value = "Address Line1"
HAdd =
(FoundCell.EntireColumn.Address)
Case "CCHolderName"
FoundCell.Value = "CC Holder Name"
Case "CCTransactionID"
FoundCell.Value = "CC Transaction 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 = "Country"
Case "DonationAmount"
FoundCell.Value = "Donation Amount"
Case "DonationDate"
FoundCell.Value = "Donation 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"
Case "HomeEmailAddress"
FoundCell.Value = "Home Email"
Case "LastName"
FoundCell.Value = "Last Name"
Case "LocationID"
FoundCell.Value = "Location ID"
Case "PaymentMethod"
FoundCell.Value = "Payment Method"
Case "HomePostalCode"
FoundCell.Value = "Postal Code"
Case "HomeProvince"
FoundCell.Value = "Prov"
Case "RegistrationFeeStatus"
FoundCell.Value = "Registration Fee"
Case "RegistrationFeeAmount"
FoundCell.Value = "Registration Fee
Amount"
Case "TaxReceiptAmount"
FoundCell.Value = "Tax Receipt Amount"
Case "TaxReceiptNumber"
FoundCell.Value = "Tax Receipt Number"
Case "TransactionID"
FoundCell.Value = "Trans ID"
Case "TransactionType"
FoundCell.Value = "Trans Type"
End Select
Next
'* Removes Tribute and records with no fee associated
RcdType = Array("TributeCardRecipient") '"Tribute") ',
"NotApplicable")
For Each Thing In RcdType
Do
SrcRng.Select
Set FoundCell = SrcRng.Find(What:=Thing)
If FoundCell Is Nothing Then
GoTo 2
Else
SrcRng.Find(What:=Thing).Activate
ActiveCell.EntireRow.Delete
End If
Loop
2 Next
'* Concatenates First Name and Middle Name
For Each MyCell In Range(FNm)
If MyCell.Row > 1 Then
MyCell.Formula = MyCell.Value & " " _
& MyCell.Offset(0, 1).Value
MyCell.Formula = LTrim(MyCell.Formula)
MyCell.Formula = RTrim(MyCell.Formula)
End If
Next
'*Replaces Home address with preferred business address
For Each MyCell In Range(PrefBAdd)
If MyCell.Value = "y" Then
MyCell.Offset(0, -13).Value =
Intersect(Rows(MyCell.Row), Columns(BAdd)).Value _
& " " & Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 1)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 2)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 3)).Value & " " _
& Intersect(Rows(MyCell.Row),
Columns(BAdd).Offset(0, 4)).Value
MyCell.Offset(0, -8).Value =
MyCell.Offset(0, 6).Value
MyCell.Offset(0, -7).Value =
MyCell.Offset(0, 7).Value
MyCell.Offset(0, -6).Value =
MyCell.Offset(0, 8).Value
MyCell.Offset(0, -5).Value =
MyCell.Offset(0, 9).Value
End If
Next
'*Concatenates Home into one column for each
For Each MyCell In Range(HAdd)
If Not MyCell.Value = "" Then
If MyCell.Row > 1 Then
MyCell.Formula = MyCell.Value & " " _
& MyCell.Offset(0, 1).Value & " " _
& MyCell.Offset(0, 2).Value & " " _
& MyCell.Offset(0, 3).Value & " " _
& MyCell.Offset(0, 4).Value
MyCell.Formula = LTrim(MyCell.Formula)
MyCell.Formula = RTrim(MyCell.Formula)
End If
End If
Next
'* 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
Columns(Thing).Select
Application.DisplayAlerts = False
With Selection.Columns
.TextToColumns
Destination:=Columns(Thing), Other:=True, OtherChar:="T"
.NumberFormat = "m/d/yyyy"
End With
Application.DisplayAlerts = True
'* Remove records outside of report date range
SrcRng.AutoFilter Field:=Thing, Criteria1:="<"
& RptDate
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
SrcRng.AutoFilter Field:=Thing,
Criteria1:=">=" & EndRptDate
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
If Thing = DonDte Then
Cells(1, Thing).Value = "Donation Date"
Else
Cells(1, Thing).Value = "Registration Date"
End If
Next
Set MyCell = SrcHdrRng.Find("PaymentStatus").Columns
SrcRng.AutoFilter Field:=MyCell.Column,
Criteria1:="*Failed*"
Set Rng2 =
SrcRng.Columns(1).SpecialCells(xlVisible).EntireRow
Rng2.Delete
SrcWS.AutoFilterMode = False
SrcLast = LastRow(SrcWS)