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)

Hard to comment but the one thing I notice is that you are using an integer
to hold the row number. Integers have a limit of 32k while the rows go to
65k...

Replace
Dim SrcLast As Integer 'Last row of data in WS
with
Dim SrcLast As Long 'Last row of data in WS

It is also interesting to note that Longs are actually more efficient than
integers. Integers are 16 bit but your OS is 32 bit so there is extra
overhead for VBA to handle integers as they need to be coerced into 16 bit.
The only real use for them is some processes can return integers and then you
need to use them...

--
HTH...

Jim Thomlinson


"(E-Mail Removed)" wrote:

> 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"

Thank you Jim, I know there is a lot of code there but that helps.
I'll replace my integers with Long. I knew about the limits, but I
didn't think there was a bit relationship as well.

I cleaned up some of my other code to make it simpler and more
efficient, and it started working again. I don't understand why it
would stop, but perhaps it was some sort of buffer overload. Excel
crashed a couple of times before it started working again.

Again, thank you.


Steven

On Aug 14, 5:22*pm, Jim Thomlinson <James_Thomlin...@owfg-Re-Move-
This-.com> wrote:
> Hard to comment but the one thing I notice is that you are using an integer
> to hold the row number. Integers have a limit of 32k while the rows go to
> 65k...
>
> Replace
> Dim SrcLast As Integer * * * * *'Last row of data in WS
> with
> Dim SrcLast As Long * * * * *'Last row of data in WS
>
> It is also interesting to note that Longs are actually more efficient than
> integers. Integers are 16 bit but your OS is 32 bit so there is extra
> overhead for VBA to handle integers as they need to be coerced into 16 bit.
> The only real use for them is some processes can return integers and thenyou
> need to use them...
>
> --
> HTH...
>
> Jim Thomlinson
>
> "sbit...@gmail.com" wrote:
> > 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 responsefield
>
> > '*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"