Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Register Log in
  • Congratulations Mike Lewis on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Any tips to make this VBA code better?

Status
Not open for further replies.
Groves22

Groves22

Technical User
Jan 29, 2009
102
US
I have to following code I have been working on for a long time. I have made several tweaks to improve it's efficiency. This is only part of the code, as other parts are similar in text. And help would be greatly appreciated.

Thanks!

Code: 
Public data_year As String, data_month As String, data_day As String, count1 As Integer, count2 As Integer, count3 As Integer, count4 As Integer, countT As Integer

Sub Update_Property_Profile()

'Make sure a new copy with the new date has been saved in the folder
Dim Response
Response = MsgBox("Did you create a copy of the profile with newest data date?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "Please create a copy with the new date before continuing.", vbOKOnly, "Create New Copy"
    Exit Sub
End If

'Gather the date of the new data
data_year = InputBox("Please enter year:", "What year")
data_month = InputBox("Please enter month (##):", "What month")
data_day = InputBox("Please enter day (##):", "What day")

Response = MsgBox("Is this the correct date: " & data_month & "/" & data_day & "/" & data_year & "?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "I'm sorry, but you have to start over.", vbOKOnly, "Please Try Again"
    Exit Sub
End If

'Update the profile with the newewst data
Call Update_monthly_Profile
Call Update_YTD_Profile

'Finishing touches on profile appearance
Call Finish_Profile

End Sub

Sub Update_monthly_Profile()

'     *************************************************
'     *             Update monthly Sales              *
'     *************************************************

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & data_year & data_month & data_day & " Sales - M.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
 
'Open and set up monthly sale Profile tab
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Ohio Property Profile v2 " & data_month & data_day & data_year & ".xls")

Set Sales_M = Workbooks(data_year & data_month & data_day & " Sales - M.xls")
Set P_Profile = Workbooks("Ohio Property Profile v2 " & data_month & data_day & data_year & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

Dim i As Integer
For i = 1 To 5
    P_Profile.Sheets(i).Visible = True
Next i

Sheets(5).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
Sales_M.Activate
    Sales_M.Sheets(2).Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sales_M.Sheets(2).Range("F2:H2", Sheets(2).Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(5).Range("B3")
    Sales_M.Sheets(2).Range("I2:M2", Sheets(2).Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(5).Range("F3")
    Sales_M.Sheets(2).Range("S2:X2", Sheets(2).Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(5).Range("N3")
    Sales_M.Sheets(2).Range("AA2:AG2", Sheets(2).Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(5).Range("Z3")
    Sales_M.Sheets(2).Range("AH2", Sheets(2).Range("AH2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AH3")
    Sales_M.Sheets(2).Range("AI2", Sheets(2).Range("AI2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AY3")
  
'Copy down formulas in profile tab
P_Profile.Sheets(5).Activate
Sheets(5).Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        count1 = Sheets(5).Range("B1").Value
Sheets(5).Range("A3").AutoFill Destination:=Range(Cells(3, 1), Cells(count1 + 3, 1))
Sheets(5).Range("E3").AutoFill Destination:=Range(Cells(3, 5), Cells(count1 + 3, 5))
 
'Show all data from data tab
Sales_M.Sheets(2).ShowAllData

'Paste Formula's into profile data sheet
P_Macro.Sheets(1).Range("CVA_Form").Copy P_Profile.Sheets(5).Range("K3")
    Range("K3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
    Range("K3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
Range("K3").Copy Range("L3")
    Range("L3").Replace What:=",12,", Replacement:=",13,", LookAt:= _
    xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False
        Sheets(5).Range("K3:L3").AutoFill Destination:=Range(Cells(3, 11), Cells(count1 + 3, 12))
            Calculate
    Sheets(5).Columns("K:L").Copy
    Sheets(5).Columns("K:L").PasteSpecial xlPasteValues

P_Macro.Sheets(1).Range("WH_Form").Copy P_Profile.Sheets(5).Range("M3")
        Range("M3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("M3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("M3").AutoFill Destination:=Range(Cells(3, 13), Cells(count1 + 3, 13))
                Calculate
    Sheets(5).Columns("M:M").Copy
    Sheets(5).Columns("M:M").PasteSpecial xlPasteValues

P_Macro.Sheets(1).Range("MP_Form").Copy P_Profile.Sheets(5).Range("T3")
        Range("T3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("T3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("T3").AutoFill Destination:=Range(Cells(3, 20), Cells(count1 + 3, 20))
                Calculate
    Sheets(5).Columns("T:T").Copy
    Sheets(5).Columns("T:T").PasteSpecial xlPasteValues
        
P_Macro.Sheets(1).Range("LC_Form").Copy P_Profile.Sheets(5).Range("W3")
        Range("W3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("W3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("W3").AutoFill Destination:=Range(Cells(3, 23), Cells(count1 + 3, 23))

P_Macro.Sheets(1).Range("NP_Form").Copy P_Profile.Sheets(5).Range("X3")
        Range("X3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("X3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("X3").AutoFill Destination:=Range(Cells(3, 24), Cells(count1 + 3, 24))
            
P_Macro.Sheets(1).Range("RC_Form").Copy P_Profile.Sheets(5).Range("Y3")
        Range("Y3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("Y3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("Y3").AutoFill Destination:=Range(Cells(3, 25), Cells(count1 + 3, 25))
        
    Calculate
    Sheets(5).Columns("W:Y").Copy
    Sheets(5).Columns("W:Y").PasteSpecial xlPasteValues
        
P_Macro.Sheets(1).Range("Assoc_Form").Copy P_Profile.Sheets(5).Range("U3")
        Range("U3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("U3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("U3").AutoFill Destination:=Range(Cells(3, 21), Cells(count1 + 3, 21))
            
P_Macro.Sheets(1).Range("PD_Form").Copy P_Profile.Sheets(5).Range("V3")
        Range("V3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("V3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("V3").AutoFill Destination:=Range(Cells(3, 22), Cells(count1 + 3, 22))
        
    Calculate
    Sheets(5).Columns("U:V").Copy
    Sheets(5).Columns("U:V").PasteSpecial xlPasteValues
        
P_Macro.Sheets(1).Range("OT_Form").Copy P_Profile.Sheets(5).Range("AG3")
        Range("AG3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AG3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("AG3").AutoFill Destination:=Range(Cells(3, 33), Cells(count1 + 3, 33))
        
    Calculate
    Sheets(5).Columns("AG:AG").Copy
    Sheets(5).Columns("AG:AG").PasteSpecial xlPasteValues
        
P_Macro.Sheets(1).Range("HM_Form").Copy P_Profile.Sheets(5).Range("AI3")
        Range("AI3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AI3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AI3").AutoFill Destination:=Range(Cells(3, 35), Cells(count1 + 3, 35))
              
P_Macro.Sheets(1).Range("ML55_Form").Copy P_Profile.Sheets(5).Range("AJ3")
        Range("AJ3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AJ3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AJ3").AutoFill Destination:=Range(Cells(3, 36), Cells(count1 + 3, 36))
    
    Sheets(5).Range("AJ3").Copy Sheets(5).Range("AL3")
        Range("AL3").Replace What:="&$AJ$1", Replacement:="&$AL$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AJ3").Copy Sheets(5).Range("AM3")
        Range("AM3").Replace What:="&$AJ$1", Replacement:="&$AM$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("AL3:AM3").AutoFill Destination:=Range(Cells(3, 38), Cells(count1 + 3, 39))
        
P_Macro.Sheets(1).Range("ML208_Form").Copy P_Profile.Sheets(5).Range("AK3")
        Range("AK3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AK3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("AK3").AutoFill Destination:=Range(Cells(3, 37), Cells(count1 + 3, 37))
        
    Sheets(5).Range("AK3").Copy Sheets(5).Range("AN3")
        Range("AN3").Replace What:="&$AK$1", Replacement:="&$AN$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("AN3").AutoFill Destination:=Range(Cells(3, 40), Cells(count1 + 3, 40))
             
P_Macro.Sheets(1).Range("ML61_Form").Copy P_Profile.Sheets(5).Range("AO3")
        Range("AO3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AO3").Replace What:="#REF", Replacement:="Sheet2", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AP3")
        Range("AP3").Replace What:="&$AO$1", Replacement:="&$AP$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AQ3")
        Range("AQ3").Replace What:="&$AO$1", Replacement:="&$AQ$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AR3")
        Range("AR3").Replace What:="&$AO$1", Replacement:="&$AR$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AS3")
        Range("AS3").Replace What:="&$AO$1", Replacement:="&$AS$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AT3")
        Range("AT3").Replace What:="&$AO$1", Replacement:="&$AT$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AU3")
        Range("AU3").Replace What:="&$AO$1", Replacement:="&$AU$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AV3")
        Range("AV3").Replace What:="&$AO$1", Replacement:="&$AV$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AW3")
        Range("AW3").Replace What:="&$AO$1", Replacement:="&$AW$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3").Copy Sheets(5).Range("AX3")
        Range("AX3").Replace What:="&$AO$1", Replacement:="&$AX$1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets(5).Range("AO3:AX3").AutoFill Destination:=Range(Cells(3, 41), Cells(count1 + 3, 50))
    Calculate
    Sheets(5).Columns("AI:AX").Copy
    Sheets(5).Columns("AI:AX").PasteSpecial xlPasteValues
        
P_Macro.Sheets(1).Range("Prem_Form").Copy P_Profile.Sheets(5).Range("AZ3")
        Range("AZ3").Replace What:="20081231", Replacement:=data_year & data_month & data_day, LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AZ3").Replace What:="#REF", Replacement:="Sheet1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AZ3").Replace What:="Sheet2", Replacement:="Sheet1", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
        Range("AZ3").Replace What:=",$A$3,", Replacement:=",$A3,", LookAt:= _
        xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
            Sheets(5).Range("AZ3").AutoFill Destination:=Range(Cells(3, 52), Cells(count1 + 3, 52))

    Calculate
    Sheets(5).Columns("AZ:AZ").Copy
    Sheets(5).Columns("AZ:AZ").PasteSpecial xlPasteValues
        
'Update formulas for counts
Sheets(5).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(count1 + 3, 194))
Calculate

'Save and close monthly sales data workbook
Sales_M.Application.DisplayAlerts = False
Sales_M.Sheets(1).Delete
Sales_M.Application.DisplayAlerts = True
Sales_M.Save
Sales_M.Close
 
Sort by date Sort by votes
It should be more efficient if you set ScreenUpdating to false before you update your sheets.

Remember to set it back to true when you've finished to see your changes.

Hope this helps

HarleyQuinn
---------------------------------
The most overlooked advantage to owning a computer is that if they foul up there's no law against wacking them around a little. - Joe Martin

Get the most out of Tek-Tips, read FAQ222-2244 before posting.
 
Upvote 0 Downvote
Hi,

Where blocks of code reference the same object, you can use the With...End With construct...
Code: 
'Filter and paste policy data from data sheet to profile tab
'    Sales_M.Activate  DON NOT NEED TO ACTIVATE
    With Sales_M.Sheets(2)
        .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Range("F2:H2", Sheets(2).Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(5).Range("B3")
        .Range("I2:M2", Sheets(2).Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(5).Range("F3")
        .Range("S2:X2", Sheets(2).Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(5).Range("N3")
        .Range("AA2:AG2", Sheets(2).Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(5).Range("Z3")
        .Range("AH2", Sheets(2).Range("AH2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AH3")
    End With

Skip,
[sup][glasses]Don't let the Diatribe...
talk you to death![tongue][/sup][sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
Skip, I guess uou meant this:
Code: 
'Filter and paste policy data from data sheet to profile tab
'    Sales_M.Activate  DON NOT NEED TO ACTIVATE
    With Sales_M.Sheets(2)
        .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
        .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(5).Range("B3")
        .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(5).Range("F3")
        .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(5).Range("N3")
        .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(5).Range("Z3")
        .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AH3")
    End With

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote
Thanks for some quick replies.

Why does the code fail when I made the following change?

Turned this:
Code: 
'Copy down formulas in profile tab
P_Profile.Sheets(5).Activate
Sheets(5).Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        count1 = Sheets(5).Range("B1").Value
Sheets(5).Range("A3").AutoFill Destination:=Range(Cells(3, 1), Cells(count1 + 3, 1))
Sheets(5).Range("E3").AutoFill Destination:=Range(Cells(3, 5), Cells(count1 + 3, 5))

Into this:

Code: 
With P_Profile.Sheets(5)
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        count1 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(Cells(3, 1), Cells(count1 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(Cells(3, 5), Cells(count1 + 3, 5))
End With

I get a "Run-time error '1004': AutoFill method of Range class failed" error

Thanks!
 
Upvote 0 Downvote
I can't generate test data without knowing a lot more, and haven't examined the code in great detail - and I'm sure there are better Excel people than me here, but ..

There is a lot of very repetetive code in there; tidying it up will makeit easier to see what is going on. Create a parameterised separate procedure something along these lines - and use consistent referencing (here I assume P_Profile.Sheets(5) is the active sheet):

Code: 
[blue]Sub NewProcedure(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    
    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=data_year & data_month & data_day, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
                                   
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
                                           
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count1 + 3, TargetColumn))
    End With
    
    Columns(TargetColumn).Copy
    Columns(TargetColumn).PasteSpecial xlPasteValues

End Sub[/blue]

When you have this you can replace a lot of code in the main procedure, along these lines:

Code: 
[blue]    NewProcedure P_Macro.Sheets(1).Range("WH_Form"), 13
    NewProcedure P_Macro.Sheets(1).Range("MP_Form"), 20
    NewProcedure P_Macro.Sheets(1).Range("LC_Form"), 23
    NewProcedure P_Macro.Sheets(1).Range("NP_Form"), 24
    NewProcedure P_Macro.Sheets(1).Range("RC_Form"), 25[/blue]

You know better than I which lines are duplicated, with just the Range changing.

Enjoy,
Tony

------------------------------------------------------------------------------------
We want to help you; help us to do it by reading this: Before you ask a question.

I'm working (slowly) on my own website
 
Upvote 0 Downvote
.Range("A3").AutoFill Destination:=Range([!].[/!]Cells(3, 1), [!].[/!]Cells(count1 + 3, 1))
.Range("E3").AutoFill Destination:=Range([!].[/!]Cells(3, 5), [!].[/!]Cells(count1 + 3, 5))

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886
 
Upvote 0 Downvote


When you previously ACTIVATED the sheet, ALL the range object references defaulted to the Active sheet, IMPLICITLY.

When you REFERENCE a sheet that is not active, you must EXPLICITLY reference ALL range objects. Hence the [red]RED dots[/red] in PHV's reply.

Skip,
[sup][glasses]Don't let the Diatribe...
talk you to death![tongue][/sup][sub]
[glasses]Just traded in my old subtlety...
for a NUANCE![tongue][/sub]
 
Upvote 0 Downvote
I offer the following general tips. I saw some of these in your code, but not all. Still, this is what I try to keep in mind when writing new macros:

Avoid Activate and Select unless you are dictating which sheet the user sees and which cell is active for the user when the macro ends.

Also avoid loops whenever possible. They tend to be slow and there is often a better/faster way to get the job done.

I really like firefytr's idea of having all of the usual "speed-things-up" settings in a single macro that can be called at the beginning and end of all your macros.

From thread707-1407494:
firefytr AKA Zack Barresse) said:
Code: 
sub ToggleEvents(blnState as boolean)
    With Application
        .Displayalerts = blnstate
        .enableevents = blnstate
        .screenupdating = blnstate
        If blnstate = true then
            .cutcopymode = not blnstate
            .statusbar = not blnstate
        end if
    end with
end sub
Call before/after routine, i.e. ...
Code: 
Sub MyRoutine()
    Call ToggleEvents(False)
    'run your code here...
    Call ToggleEvents(True)
End sub
Click to expand...
Also, when you don't need calculation to be automatic, this can really save time on large workbooks with lots of formulas:
Code: 
Application.Calculation = xlCalculationManual
'...
Application.Calculation = xlCalculationAutomatic

[tt][blue]-John[/blue][/tt]
[tab][red]The plural of anecdote is not data[/red]

Help us help you. Please read FAQ 181-2886 before posting.
 
Upvote 0 Downvote
Thank you PHV and Skip!
Also, Thanks Tony, you have saved me tons of lines!

When I finish updating with all of the great tips, I will repost and see if anymore could be done.

You guys are a big help with a novice like me! :)
 
Upvote 0 Downvote
Hey all...

Here is my code, in full, which is about the same length as the code I gave earlier (which was only 25% of the code).

Obviously you don't have to try to do miracle work on the entire code, but if there are any other tips you can see, please let me know!!

Thanks

Code: 
Public dyear As String, dmonth As String, dday As String, count1 As Integer, count2 As Integer, count3 As Integer, count4 As Integer, countT As Integer

Sub Update_Property_Profile()

'Make sure a new copy with the new date has been saved in the folder
Dim Response
Response = MsgBox("Did you create a copy of the profile with newest data date?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "Please create a copy with the new date before continuing.", vbOKOnly, "Create New Copy"
    Exit Sub
End If

'Gather the date of the new data
dyear = InputBox("Please enter year:", "What year")
dmonth = InputBox("Please enter month (##):", "What month")
dday = InputBox("Please enter day (##):", "What day")

Response = MsgBox("Is this the correct date: " & dmonth & "/" & dday & "/" & dyear & "?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "I'm sorry, but you have to start over.", vbOKOnly, "Please Try Again"
    Exit Sub
End If

'Update the profile with the newewst data
Call Update_monthly_Profile
Call Update_YTD_Profile

'Finishing touches on profile appearance
Call Finish_Profile

End Sub

Sub Update_monthly_Profile()

'     *************************************************
'     *             Update monthly Sales              *
'     *************************************************

Application.Calculation = xlCalculationManual

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Sales - M.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
 
'Open and set up monthly sale Profile tab
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")

Set Sales_M = Workbooks(dyear & dmonth & dday & " Sales - M.xls")
Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

Dim i As Integer
For i = 1 To 5
    P_Profile.Sheets(i).Visible = True
Next i

Sheets(5).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Sales_M.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(5).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(5).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(5).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(5).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(5)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count1 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count1 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count1 + 3, 5))
End With
     
'Show all data from data tab
Sales_M.Sheets(2).ShowAllData
P_Profile.Sheets(5).Activate

'Paste Formula's into profile data sheet
With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(5).Range("K3")
      RepSalesM P_Profile.Sheets(5).Range("K3"), 11
    
    .Range("CVA_Form").Copy P_Profile.Sheets(5).Range("L3")
        RepSalesM P_Profile.Sheets(5).Range("L3"), 12
    
    .Range("WH_Form").Copy P_Profile.Sheets(5).Range("M3")
     RepSalesM P_Profile.Sheets(5).Range("M3"), 13

    .Range("MP_Form").Copy P_Profile.Sheets(5).Range("T3")
        RepSalesM P_Profile.Sheets(5).Range("T3"), 20
            
    .Range("LC_Form").Copy P_Profile.Sheets(5).Range("W3")
        RepSalesM P_Profile.Sheets(5).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(5).Range("X3")
        RepSalesM P_Profile.Sheets(5).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(5).Range("Y3")
        RepSalesM P_Profile.Sheets(5).Range("Y3"), 25
            
    .Range("Assoc_Form").Copy P_Profile.Sheets(5).Range("U3")
        RepSalesM P_Profile.Sheets(5).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(5).Range("V3")
        RepSalesM P_Profile.Sheets(5).Range("V3"), 22
            
    .Range("OT_Form").Copy P_Profile.Sheets(5).Range("AG3")
        RepSalesM P_Profile.Sheets(5).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(5).Range("AI3")
        RepSalesM P_Profile.Sheets(5).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(5).Range("AJ3")
        RepSalesM P_Profile.Sheets(5).Range("AJ3"), 36
        
    .Range("ML55_Form").Copy P_Profile.Sheets(5).Range("AL3")
        RepSalesM P_Profile.Sheets(5).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(5).Range("AM3")
        RepSalesM P_Profile.Sheets(5).Range("AM3"), 39
            
    .Range("ML208_Form").Copy P_Profile.Sheets(5).Range("AK3")
        RepSalesM P_Profile.Sheets(5).Range("AK3"), 37
        
    .Range("ML208_Form").Copy P_Profile.Sheets(5).Range("AN3")
        RepSalesM P_Profile.Sheets(5).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(5).Range("AO3:AX3")
        Dim j As Long
            For j = 41 To 50
                RepSalesM P_Profile.Sheets(5).Cells(3, j), j
            Next j
            
    .Range("Prem_Form").Copy P_Profile.Sheets(5).Range("AZ3")
        RepSalesM P_Profile.Sheets(5).Range("AZ3"), 52
End With
        
'Update formulas for counts
Sheets(5).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(count1 + 3, 194))
Calculate

'Save and close monthly sales data workbook
With Sales_M
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

'     **************************************************
'     *             Update monthly Quotes              *
'     **************************************************

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Quotes - M.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Quotes_M = Workbooks(dyear & dmonth & dday & " Quotes - M.xls")

P_Profile.Sheets(4).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Quotes_M.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(4).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(4).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(4).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(4).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(4).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(4).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(4)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count2 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count2 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count2 + 3, 5))
End With
 
'Show all data from data tab
Quotes_M.Sheets(2).ShowAllData
P_Profile.Sheets(4).Activate

'Paste Formula's into profile data sheet
With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(4).Range("K3")
        RepQuotesM P_Profile.Sheets(4).Range("K3"), 11
        
    .Range("CVA_Form").Copy P_Profile.Sheets(4).Range("L3")
        RepQuotesM P_Profile.Sheets(4).Range("L3"), 12
        
    .Range("WH_Form").Copy P_Profile.Sheets(4).Range("M3")
        RepQuotesM P_Profile.Sheets(4).Range("M3"), 13
    
    .Range("MP_Form").Copy P_Profile.Sheets(4).Range("T3")
        RepQuotesM P_Profile.Sheets(4).Range("T3"), 20
            
    .Range("LC_Form").Copy P_Profile.Sheets(4).Range("W3")
        RepQuotesM P_Profile.Sheets(4).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(4).Range("X3")
        RepQuotesM P_Profile.Sheets(4).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(4).Range("Y3")
        RepQuotesM P_Profile.Sheets(4).Range("Y3"), 25
            
    .Range("Assoc_Form").Copy P_Profile.Sheets(4).Range("U3")
        RepQuotesM P_Profile.Sheets(4).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(4).Range("V3")
        RepQuotesM P_Profile.Sheets(4).Range("V3"), 22
            
    .Range("OT_Form").Copy P_Profile.Sheets(4).Range("AG3")
        RepQuotesM P_Profile.Sheets(4).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(4).Range("AI3")
        RepQuotesM P_Profile.Sheets(4).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(4).Range("AJ3")
        RepQuotesM P_Profile.Sheets(4).Range("AJ3"), 36
        
    .Range("ML55_Form").Copy P_Profile.Sheets(4).Range("AL3")
        RepQuotesM P_Profile.Sheets(4).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(4).Range("AM3")
        RepQuotesM P_Profile.Sheets(4).Range("AM3"), 39
            
    .Range("ML208_Form").Copy P_Profile.Sheets(4).Range("AK3")
        RepQuotesM P_Profile.Sheets(4).Range("AK3"), 37
        
    .Range("ML208_Form").Copy P_Profile.Sheets(4).Range("AN3")
        RepQuotesM P_Profile.Sheets(4).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(4).Range("AO3:AX3")
        Dim h As Long
            For h = 41 To 50
                RepQuotesM P_Profile.Sheets(4).Cells(3, h), h
            Next h
            
    .Range("Prem_Form").Copy P_Profile.Sheets(4).Range("AZ3")
        RepQuotesM P_Profile.Sheets(4).Range("AZ3"), 52
End With
        
'Copy sales to quotes tab
P_Profile.Sheets(5).Select
P_Profile.Sheets(5).Range(Cells(3, 1), Cells(count1 + 3, 52)).Copy
P_Profile.Sheets(4).Select
P_Profile.Sheets(4).Cells(count2 + 4, 1).Select
ActiveSheet.Paste
            
'Update formulas for counts
countT = count1 + count2
P_Profile.Sheets(4).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(countT + 4, 194))
Calculate

'Save and close monthly quotes data workbook
With Quotes_M
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

End Sub

Sub Update_YTD_Profile()

'     *************************************************
'     *             YTD monthly Sales                 *
'     *************************************************

Application.Calculation = xlCalculationManual

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Sales.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Sales = Workbooks(dyear & dmonth & dday & " Sales.xls")
Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

P_Profile.Sheets(3).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Sales.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(3).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(3).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(3).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(3).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(3).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(3).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(3)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count3 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count3 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count3 + 3, 5))
End With
 
'Show all data from data tab
Sales.Sheets(2).ShowAllData
P_Profile.Sheets(3).Activate

'Paste Formula's into profile data sheet
With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(3).Range("K3")
        RepSales P_Profile.Sheets(3).Range("K3"), 11
        
    .Range("CVA_Form").Copy P_Profile.Sheets(3).Range("L3")
        RepSales P_Profile.Sheets(3).Range("L3"), 12
        
    .Range("WH_Form").Copy P_Profile.Sheets(3).Range("M3")
        RepSales P_Profile.Sheets(3).Range("M3"), 13
    
    .Range("MP_Form").Copy P_Profile.Sheets(3).Range("T3")
        RepSales P_Profile.Sheets(3).Range("T3"), 20
            
    .Range("LC_Form").Copy P_Profile.Sheets(3).Range("W3")
        RepSales P_Profile.Sheets(3).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(3).Range("X3")
        RepSales P_Profile.Sheets(3).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(3).Range("Y3")
        RepSales P_Profile.Sheets(3).Range("Y3"), 25
            
    .Range("Assoc_Form").Copy P_Profile.Sheets(3).Range("U3")
        RepSales P_Profile.Sheets(3).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(3).Range("V3")
        RepSales P_Profile.Sheets(3).Range("V3"), 22
            
    .Range("OT_Form").Copy P_Profile.Sheets(3).Range("AG3")
        RepSales P_Profile.Sheets(3).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(3).Range("AI3")
        RepSales P_Profile.Sheets(3).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(3).Range("AJ3")
        RepSales P_Profile.Sheets(3).Range("AJ3"), 36
        
    .Range("ML55_Form").Copy P_Profile.Sheets(3).Range("AL3")
        RepSales P_Profile.Sheets(3).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(3).Range("AM3")
        RepSales P_Profile.Sheets(3).Range("AM3"), 39
            
    .Range("ML208_Form").Copy P_Profile.Sheets(3).Range("AK3")
        RepSales P_Profile.Sheets(3).Range("AK3"), 37
        
    .Range("ML208_Form").Copy P_Profile.Sheets(3).Range("AN3")
        RepSales P_Profile.Sheets(3).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(3).Range("AO3:AX3")
        Dim l As Long
            For l = 41 To 50
                RepSales P_Profile.Sheets(3).Cells(3, l), l
            Next l
            
    .Range("Prem_Form").Copy P_Profile.Sheets(3).Range("AZ3")
        RepSales P_Profile.Sheets(3).Range("AZ3"), 52
End With
        
'Update formulas for counts
Sheets(3).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(count3 + 3, 194))
Calculate

'Save and close monthly quotes data workbook
With Sales
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

'     **************************************************
'     *               YTD monthly Quotes               *
'     **************************************************

'Open and set up data monthly quote sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Quotes.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Quotes = Workbooks(dyear & dmonth & dday & " Quotes.xls")

P_Profile.Sheets(2).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Quotes.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(2).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(2).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(2).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(2).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(2).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(2).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(2)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count4 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count4 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count4 + 3, 5))
End With
 
'Show all data from data tab
Quotes.Sheets(2).ShowAllData
P_Profile.Sheets(2).Activate

'Paste Formula's into profile data sheet
With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("K3")
        RepQuotes P_Profile.Sheets(2).Range("K3"), 11
        
    .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("L3")
        RepQuotes P_Profile.Sheets(2).Range("L3"), 12
        
    .Range("WH_Form").Copy P_Profile.Sheets(2).Range("M3")
        RepQuotes P_Profile.Sheets(2).Range("M3"), 13
    
    .Range("MP_Form").Copy P_Profile.Sheets(2).Range("T3")
        RepQuotes P_Profile.Sheets(2).Range("T3"), 20
            
    .Range("LC_Form").Copy P_Profile.Sheets(2).Range("W3")
        RepQuotes P_Profile.Sheets(2).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(2).Range("X3")
        RepQuotes P_Profile.Sheets(2).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(2).Range("Y3")
        RepQuotes P_Profile.Sheets(2).Range("Y3"), 25
            
    .Range("Assoc_Form").Copy P_Profile.Sheets(2).Range("U3")
        RepQuotes P_Profile.Sheets(2).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(2).Range("V3")
        RepQuotes P_Profile.Sheets(2).Range("V3"), 22
            
    .Range("OT_Form").Copy P_Profile.Sheets(2).Range("AG3")
        RepQuotes P_Profile.Sheets(2).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(2).Range("AI3")
        RepQuotes P_Profile.Sheets(2).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AJ3")
        RepQuotes P_Profile.Sheets(2).Range("AJ3"), 36
        
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AL3")
        RepQuotes P_Profile.Sheets(2).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AM3")
        RepQuotes P_Profile.Sheets(2).Range("AM3"), 39
            
    .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AK3")
        RepQuotes P_Profile.Sheets(2).Range("AK3"), 37
        
    .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AN3")
        RepQuotes P_Profile.Sheets(2).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(2).Range("AO3:AX3")
        Dim r As Long
            For r = 41 To 50
                RepQuotes P_Profile.Sheets(2).Cells(3, r), r
            Next r
            
    .Range("Prem_Form").Copy P_Profile.Sheets(2).Range("AZ3")
        RepQuotes P_Profile.Sheets(2).Range("AZ3"), 52
End With
        
'Copy sales to quotes tab
P_Profile.Sheets(3).Select
P_Profile.Sheets(3).Range(Cells(3, 1), Cells(count3 + 3, 52)).Copy
P_Profile.Sheets(2).Select
P_Profile.Sheets(2).Cells(count4 + 4, 1).Select
ActiveSheet.Paste
            
'Update formulas for counts
countT = count3 + count4
P_Profile.Sheets(2).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(countT + 4, 194))
Calculate

'Save and close monthly quotes data workbook
With Quotes
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

End Sub

Sub Finish_Profile()

Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")

P_Profile.Activate

Dim k As Integer
For k = 1 To 5
    Sheets(k).Visible = False
Next k

End Sub

Sub RepSalesM(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    
    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
                 
    If TargetColumn = 12 Then
                 
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    
    ElseIf TargetColumn = 52 Then
    
        .Replace What:="Sheet2", _
                 Replacement:="Sheet1", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
    End If
                                           
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count1 + 3, TargetColumn))
    End With
    
    Calculate
    Columns(TargetColumn).Copy
    Columns(TargetColumn).PasteSpecial xlPasteValues

End Sub

Sub RepQuotesM(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    
    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
        .Replace What:="Sales - M", Replacement:="Quotes - M", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
                 
    If TargetColumn = 12 Then
                 
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    
    ElseIf TargetColumn = 52 Then
    
        .Replace What:="Sheet2", _
                 Replacement:="Sheet1", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
    End If
                                           
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count2 + 3, TargetColumn))
    End With
    
    Calculate
    Columns(TargetColumn).Copy
    Columns(TargetColumn).PasteSpecial xlPasteValues

End Sub

Sub RepSales(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    
    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
        .Replace What:="Sales - M", Replacement:="Sales", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
                 
    If TargetColumn = 12 Then
                 
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    
    ElseIf TargetColumn = 52 Then
    
        .Replace What:="Sheet2", _
                 Replacement:="Sheet1", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
    End If
                                           
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count3 + 3, TargetColumn))
    End With
    
    Calculate
    Columns(TargetColumn).Copy
    Columns(TargetColumn).PasteSpecial xlPasteValues

End Sub

Sub RepQuotes(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    
    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
        .Replace What:="Sales - M", Replacement:="Quotes", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
                 
    If TargetColumn = 12 Then
                 
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    
    ElseIf TargetColumn = 52 Then
    
        .Replace What:="Sheet2", _
                 Replacement:="Sheet1", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
    End If
                                           
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count4 + 3, TargetColumn))
    End With
    
    Calculate
    Columns(TargetColumn).Copy
    Columns(TargetColumn).PasteSpecial xlPasteValues

End Sub
 
Upvote 0 Downvote
it looks like the last 4 procedure could be consolidated into 1 and you would have to send 2 more parameters
This may not speed up your code but will shorten it some

1. the replacement for sales-m
and a variable to consolidate for count1, count2, count3, and count4

ck1999
 
Upvote 0 Downvote
does this line
Code: 
 SourceRange.Copy Cells(3, TargetColumn)
do anything or copy the same cell to itself?

Also it looks like you are sending adjacent columns separately to the procedures. I would think it would speed up your procedure to send them in blocks (since all are not adjacent) and this would cut down the number of searches.

Also your target column is the same as the column of the range so you could use sourcerange.column instead of sending this variable

Code: 
With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("K3")
        RepQuotes P_Profile.Sheets(2).Range("K3"), 11
        
    .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("L3")
        RepQuotes P_Profile.Sheets(2).Range("L3"), 12
        
    .Range("WH_Form").Copy P_Profile.Sheets(2).Range("M3")
        RepQuotes P_Profile.Sheets(2).Range("M3"), 13
    
    .Range("MP_Form").Copy P_Profile.Sheets(2).Range("T3")
        RepQuotes P_Profile.Sheets(2).Range("T3"), 20
            
    .Range("LC_Form").Copy P_Profile.Sheets(2).Range("W3")
        RepQuotes P_Profile.Sheets(2).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(2).Range("X3")
        RepQuotes P_Profile.Sheets(2).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(2).Range("Y3")
        RepQuotes P_Profile.Sheets(2).Range("Y3"), 25
            
    .Range("Assoc_Form").Copy P_Profile.Sheets(2).Range("U3")
        RepQuotes P_Profile.Sheets(2).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(2).Range("V3")
        RepQuotes P_Profile.Sheets(2).Range("V3"), 22
            
    .Range("OT_Form").Copy P_Profile.Sheets(2).Range("AG3")
        RepQuotes P_Profile.Sheets(2).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(2).Range("AI3")
        RepQuotes P_Profile.Sheets(2).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AJ3")
        RepQuotes P_Profile.Sheets(2).Range("AJ3"), 36
        
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AL3")
        RepQuotes P_Profile.Sheets(2).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AM3")
        RepQuotes P_Profile.Sheets(2).Range("AM3"), 39
            
    .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AK3")
        RepQuotes P_Profile.Sheets(2).Range("AK3"), 37
        
    .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AN3")
        RepQuotes P_Profile.Sheets(2).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(2).Range("AO3:AX3")
        Dim r As Long
            For r = 41 To 50
                RepQuotes P_Profile.Sheets(2).Cells(3, r), r
            Next r
            
    .Range("Prem_Form").Copy P_Profile.Sheets(2).Range("AZ3")
        RepQuotes P_Profile.Sheets(2).Range("AZ3"), 52
End With

with this
Code: 
"With P_Macro.Sheets(1)

        .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("K3")
        .Range("CVA_Form").Copy P_Profile.Sheets(2).Range("L3")
        .Range("WH_Form").Copy P_Profile.Sheets(2).Range("M3")
        .Range("MP_Form").Copy P_Profile.Sheets(2).Range("T3")
        .Range("LC_Form").Copy P_Profile.Sheets(2).Range("W3")
        .Range("NP_Form").Copy P_Profile.Sheets(2).Range("X3")
        .Range("RC_Form").Copy P_Profile.Sheets(2).Range("Y3")
        .Range("Assoc_Form").Copy P_Profile.Sheets(2).Range("U3")
        .Range("PD_Form").Copy P_Profile.Sheets(2).Range("V3")
        .Range("OT_Form").Copy P_Profile.Sheets(2).Range("AG3")
        .Range("HM_Form").Copy P_Profile.Sheets(2).Range("AI3")
        .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AJ3")
        .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AK3")
        .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AL3")
        .Range("ML55_Form").Copy P_Profile.Sheets(2).Range("AM3")
        .Range("ML208_Form").Copy P_Profile.Sheets(2).Range("AN3")
        .Range("ML61_Form").Copy P_Profile.Sheets(2).Range("AO3:AX3")
        .Range("Prem_Form").Copy P_Profile.Sheets(2).Range("AZ3")
        
        RepQuotes P_Profile.Sheets(2).Range("K3", "M3")
        RepQuotes P_Profile.Sheets(2).Range("T3", "y3")
        RepQuotes P_Profile.Sheets(2).Range("AG3"), 33
        RepQuotes P_Profile.Sheets(2).Range("AI3", "Ax3")
        RepQuotes P_Profile.Sheets(2).Range("AZ3"), 52
End With

and then change the repquotes procedure to

Code: 
Sub RepQuotes(SourceRange As Range)

  '  SourceRange.Copy Cells(3, TargetColumn)
    
    With SourceRange
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
        .Replace What:="Sales - M", Replacement:="Quotes", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    End With
    With Range("L3")
                 
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    End With
    
    With Range("az3")
    
        .Replace What:="Sheet2", _
                 Replacement:="Sheet1", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
        
    End With
                                           
  '      .AutoFill Destination:=Range(SourceRange, Cells(count3 + 3, TargetColumn))
    End With
    
    Calculate
    SourceRange.Copy
    SourceRange.PasteSpecial xlPasteValues

End Sub

ck1999
 
Upvote 0 Downvote
Thanks ck1999. However, the last code produced an error, which I forget now.

I was able to shrink my code some more.

ck, if the code your produced is still valid with my new line of code, can you offer it again with the recent change?

Thanks!

Code: 
Public dyear As String, dmonth As String, dday As String, count1 As Integer, count2 As Integer, count3 As Integer, count4 As Integer, countT As Integer, RepNum As Integer

Sub Update_Property_Profile()

'Make sure a new copy with the new date has been saved in the folder
Dim Response
Response = MsgBox("Did you create a copy of the profile with newest data date?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "Please create a copy with the new date before continuing.", vbOKOnly, "Create New Copy"
    Exit Sub
End If

'Gather the date of the new data
dyear = InputBox("Please enter year:", "What year")
dmonth = InputBox("Please enter month (##):", "What month")
dday = InputBox("Please enter day (##):", "What day")

Response = MsgBox("Is this the correct date: " & dmonth & "/" & dday & "/" & dyear & "?", vbYesNo, "Continue?")

If Response = vbNo Then
    MsgBox "I'm sorry, but you have to start over.", vbOKOnly, "Please Try Again"
    Exit Sub
End If

'Update the profile with the newewst data
Call Update_monthly_Profile
Call Update_YTD_Profile

'Finishing touches on profile appearance
Call Finish_Profile

End Sub

Sub Update_monthly_Profile()

'     *************************************************
'     *             Update monthly Sales              *
'     *************************************************

Application.Calculation = xlCalculationManual

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Sales - M.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
 
'Open and set up monthly sale Profile tab
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")

Set Sales_M = Workbooks(dyear & dmonth & dday & " Sales - M.xls")
Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

Dim i As Integer
For i = 1 To 5
    P_Profile.Sheets(i).Visible = True
Next i

Sheets(5).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Sales_M.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(5).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(5).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(5).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(5).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(5).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(5)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count1 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count1 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count1 + 3, 5))
End With
     
'Show all data from data tab
Sales_M.Sheets(2).ShowAllData
P_Profile.Sheets(5).Activate

'Paste Formula's into profile data sheet
RepNum = 5
Call Formula_Paste
        
'Update formulas for counts
Sheets(5).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(count1 + 3, 194))
Calculate

'Save and close monthly sales data workbook
With Sales_M
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

'     **************************************************
'     *             Update monthly Quotes              *
'     **************************************************

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Quotes - M.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Quotes_M = Workbooks(dyear & dmonth & dday & " Quotes - M.xls")

P_Profile.Sheets(4).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Quotes_M.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(4).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(4).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(4).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(4).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(4).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(4).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(4)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count2 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count2 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count2 + 3, 5))
End With
 
'Show all data from data tab
Quotes_M.Sheets(2).ShowAllData
P_Profile.Sheets(4).Activate

'Paste Formula's into profile data sheet
RepNum = 4
Call Formula_Paste
        
'Copy sales to quotes tab
P_Profile.Sheets(5).Select
P_Profile.Sheets(5).Range(Cells(3, 1), Cells(count1 + 3, 52)).Copy
P_Profile.Sheets(4).Select
P_Profile.Sheets(4).Cells(count2 + 4, 1).Select
ActiveSheet.Paste
            
'Update formulas for counts
countT = count1 + count2
P_Profile.Sheets(4).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(countT + 4, 194))
Calculate

'Save and close monthly quotes data workbook
With Quotes_M
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

End Sub

Sub Update_YTD_Profile()

'     *************************************************
'     *                  YTD Sales                    *
'     *************************************************

Application.Calculation = xlCalculationManual

'Open and set up data monthly sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Sales.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Sales = Workbooks(dyear & dmonth & dday & " Sales.xls")
Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

P_Profile.Sheets(3).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Sales.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(3).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(3).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(3).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(3).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(3).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(3).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(3)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count3 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count3 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count3 + 3, 5))
End With
 
'Show all data from data tab
Sales.Sheets(2).ShowAllData
P_Profile.Sheets(3).Activate

'Paste Formula's into profile data sheet
RepNum = 3
Call Formula_Paste
        
'Update formulas for counts
Sheets(3).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(count3 + 3, 194))
Calculate

'Save and close monthly quotes data workbook
With Sales
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

'     **************************************************
'     *                   YTD Quotes                   *
'     **************************************************

'Open and set up data monthly quote sheet
Workbooks.Open ("P:\STATE REVIEWS\OH\OH\New Product Set Up\Property\Profile Exhibits\Outputs\" & dyear & dmonth & dday & " Quotes.xls")
Sheets(1).Name = "Sheet2"
Sheets.Add before:=Sheets(1)
Sheets(2).Range("D:D").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    Sheets(2).Columns("E").Copy Sheets(1).Range("A1")
    Sheets(2).Columns("AJ").Copy Sheets(1).Range("B1")
    Sheets(2).ShowAllData
    
Set Quotes = Workbooks(dyear & dmonth & dday & " Quotes.xls")

P_Profile.Sheets(2).Range("A4:GL65500").ClearContents

'Filter and paste policy data from data sheet to profile tab
With Quotes.Sheets(2)
    .Range("E:E").AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    .Range("F2:H2", .Range("F2:H2").End(xlDown)).Copy P_Profile.Sheets(2).Range("B3")
    .Range("I2:M2", .Range("I2:M2").End(xlDown)).Copy P_Profile.Sheets(2).Range("F3")
    .Range("S2:X2", .Range("S2:X2").End(xlDown)).Copy P_Profile.Sheets(2).Range("N3")
    .Range("AA2:AG2", .Range("AA2:AG2").End(xlDown)).Copy P_Profile.Sheets(2).Range("Z3")
    .Range("AH2", .Range("AH2").End(xlDown)).Copy P_Profile.Sheets(2).Range("AH3")
    .Range("AI2", .Range("AI2").End(xlDown)).Copy P_Profile.Sheets(2).Range("AY3")
End With
  
'Copy down formulas in profile tab
With P_Profile.Sheets(2)
    .Activate
    .Range("B1").FormulaR1C1 = "=COUNTA(R[3]C:R[65535]C)"
        Calculate
        count4 = .Range("B1").Value
    .Range("A3").AutoFill Destination:=Range(.Cells(3, 1), .Cells(count4 + 3, 1))
    .Range("E3").AutoFill Destination:=Range(.Cells(3, 5), .Cells(count4 + 3, 5))
End With
 
'Show all data from data tab
Quotes.Sheets(2).ShowAllData
P_Profile.Sheets(2).Activate

'Paste Formula's into profile data sheet
RepNum = 2
Call Formula_Paste
        
'Copy sales to quotes tab
P_Profile.Sheets(3).Select
P_Profile.Sheets(3).Range(Cells(3, 1), Cells(count3 + 3, 52)).Copy
P_Profile.Sheets(2).Select
P_Profile.Sheets(2).Cells(count4 + 4, 1).Select
ActiveSheet.Paste
            
'Update formulas for counts
countT = count3 + count4
P_Profile.Sheets(2).Range("BA3:GL3").AutoFill Destination:=Range(Cells(3, 53), Cells(countT + 4, 194))
Calculate

'Save and close monthly quotes data workbook
With Quotes
    .Application.DisplayAlerts = False
    .Sheets(1).Delete
    .Application.DisplayAlerts = True
    .Save
    .Close
End With

End Sub

Sub Finish_Profile()

Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")

P_Profile.Activate

Dim k As Integer
For k = 1 To 5
    Sheets(k).Visible = False
Next k

End Sub

Sub Formula_Paste()

Set P_Profile = Workbooks("Ohio Property Profile v2 " & dmonth & dday & dyear & ".xls")
Set P_Macro = Workbooks("Property Profile Macros.xls")

With P_Macro.Sheets(1)
    .Range("CVA_Form").Copy P_Profile.Sheets(RepNum).Range("K3")
      RepCode P_Profile.Sheets(RepNum).Range("K3"), 11
    
    .Range("CVA_Form").Copy P_Profile.Sheets(RepNum).Range("L3")
        RepCode P_Profile.Sheets(RepNum).Range("L3"), 12
    
    .Range("WH_Form").Copy P_Profile.Sheets(RepNum).Range("M3")
        RepCode P_Profile.Sheets(RepNum).Range("M3"), 13

    .Range("MP_Form").Copy P_Profile.Sheets(RepNum).Range("T3")
        RepCode P_Profile.Sheets(RepNum).Range("T3"), 20
        
    .Range("Assoc_Form").Copy P_Profile.Sheets(RepNum).Range("U3")
        RepCode P_Profile.Sheets(RepNum).Range("U3"), 21
                
    .Range("PD_Form").Copy P_Profile.Sheets(RepNum).Range("V3")
        RepCode P_Profile.Sheets(RepNum).Range("V3"), 22
            
    .Range("LC_Form").Copy P_Profile.Sheets(RepNum).Range("W3")
        RepCode P_Profile.Sheets(RepNum).Range("W3"), 23
    
    .Range("NP_Form").Copy P_Profile.Sheets(RepNum).Range("X3")
        RepCode P_Profile.Sheets(RepNum).Range("X3"), 24
                
    .Range("RC_Form").Copy P_Profile.Sheets(RepNum).Range("Y3")
        RepCode P_Profile.Sheets(RepNum).Range("Y3"), 25
            
    .Range("OT_Form").Copy P_Profile.Sheets(RepNum).Range("AG3")
        RepCode P_Profile.Sheets(RepNum).Range("AG3"), 33
            
    .Range("HM_Form").Copy P_Profile.Sheets(RepNum).Range("AI3")
        RepCode P_Profile.Sheets(RepNum).Range("AI3"), 35
                  
    .Range("ML55_Form").Copy P_Profile.Sheets(RepNum).Range("AJ3")
        RepCode P_Profile.Sheets(RepNum).Range("AJ3"), 36
        
    .Range("ML208_Form").Copy P_Profile.Sheets(RepNum).Range("AK3")
        RepCode P_Profile.Sheets(RepNum).Range("AK3"), 37
        
    .Range("ML55_Form").Copy P_Profile.Sheets(RepNum).Range("AL3")
        RepCode P_Profile.Sheets(RepNum).Range("AL3"), 38
        
    .Range("ML55_Form").Copy P_Profile.Sheets(RepNum).Range("AM3")
        RepCode P_Profile.Sheets(RepNum).Range("AM3"), 39
        
    .Range("ML208_Form").Copy P_Profile.Sheets(RepNum).Range("AN3")
        RepCode P_Profile.Sheets(RepNum).Range("AN3"), 40
    
    .Range("ML61_Form").Copy P_Profile.Sheets(RepNum).Range("AO3:AX3")
        Dim j As Long
            For j = 41 To 50
                RepCode P_Profile.Sheets(RepNum).Cells(3, j), j
            Next j
            
    .Range("Prem_Form").Copy P_Profile.Sheets(RepNum).Range("AZ3")
        RepCode P_Profile.Sheets(RepNum).Range("AZ3"), 52
End With

End Sub

Sub RepCode(SourceRange As Range, TargetColumn As Long)

    SourceRange.Copy Cells(3, TargetColumn)
    

    With Cells(3, TargetColumn)
        .Replace What:="20081231", Replacement:=dyear & dmonth & dday, _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
    
        .Replace What:="#REF", _
                 Replacement:="Sheet2", _
                 LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                 SearchFormat:=False, ReplaceFormat:=False
                 
    If RepNum = 4 Then
        .Replace What:="Sales - M", Replacement:="Quotes - M", LookAt:= _
                xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
             
    ElseIf RepNum = 3 Then
        .Replace What:="Sales - M", Replacement:="Sales", LookAt:= _
                xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
             
    ElseIf RepNum = 2 Then
        .Replace What:="Sales - M", Replacement:="Quotes", LookAt:= _
                xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
                 
    End If
                 
    If TargetColumn = 12 Then
        .Replace What:=",12,", Replacement:=",13,", LookAt:= _
                 xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                 ReplaceFormat:=False
    
    ElseIf TargetColumn = 52 Then
        .Replace What:="Sheet2", _
                Replacement:="Sheet1", _
                LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
                SearchFormat:=False, ReplaceFormat:=False
        
    End If
    
    If RepNum = 5 Then
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count1 + 3, TargetColumn))
        
    ElseIf RepNum = 4 Then
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count2 + 3, TargetColumn))
    
    ElseIf RepNum = 3 Then
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count3 + 3, TargetColumn))

    ElseIf RepNum = 2 Then
        .AutoFill Destination:=Range(Cells(3, TargetColumn), Cells(count4 + 3, TargetColumn))

    End If
    
    End With
    
    Calculate
    With Columns(TargetColumn)
        .Copy
        .PasteSpecial xlPasteValues
    End With

End Sub
 
Upvote 0 Downvote
sorry for the error not sure where it was

Code: 
        RepQuotes P_Profile.Sheets(2).Range("K3", "M3")
        RepQuotes P_Profile.Sheets(2).Range("T3", "y3")
        RepQuotes P_Profile.Sheets(2).Range("AG3"), 33
        RepQuotes P_Profile.Sheets(2).Range("AI3", "Ax3")
        RepQuotes P_Profile.Sheets(2).Range("AZ3"), 52

should be
Code: 
        Repcode P_Profile.Sheets(2).Range("K3", "M3")
        Repcode P_Profile.Sheets(2).Range("T3", "y3")
        Repcode P_Profile.Sheets(2).Range("AG3")
        Repcode P_Profile.Sheets(2).Range("AI3", "Ax3")
        Repcode P_Profile.Sheets(2).Range("AZ3")

It this still produces the error please indicate the error.

ck1999

 
Upvote 0 Downvote
Thanks ck... That will work, once I tweak it with my updates.

Thanks again!
 
Upvote 0 Downvote
Status
Not open for further replies.

Similar threads

thanhthanh12
  • Locked
  • Question
Help vba
Replies
3
Views
333
combo
combo
Andrzejek
  • Locked
  • Question
Outlook VBA - Trust access
Replies
3
Views
464
hermanlaksko
hermanlaksko
SLW89
  • Locked
  • Question
VBA newbie needs help
Replies
4
Views
287
Andrzejek
Andrzejek
xwb
  • Locked
  • Helpful tip
Performing VBA operations in other languages
Replies
1
Views
233
strongm
strongm
Kymenglish
  • Locked
  • Question
Automated data entry code in MS Excel VB - Edge code how to hit enter to remove popups
Replies
3
Views
209
strongm
strongm

Part and Inventory Search

Sponsor

Back
Top