VBA code improvement

R

rdicarlo

New Member
Joined
Oct 2, 2009
Messages
3
Hi All,

I'm new to this forum. I've been working on some VBA code in Excel 2003. I'm am not a programmer. It seems to work. But, I wanted to post it here to see if I could get some feedback on making the code more efficient. Thanks for the help.

Rob

Here it is...

Option Explicit
Sub FormatDailyLog()
Dim sFil As String
Dim sTitle As String
Dim sWb As String
Dim sWb2 As String
Dim LastRow As Long
Dim iFilterIndex As Integer

Application.ScreenUpdating = False
Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar").DirList
On Error GoTo err_handler
sFil = "Excel Files (*.xls),*.xls"
iFilterIndex = 1
sTitle = "Select File to Format"
sWb = Application.GetOpenFilename(sFil, iFilterIndex, sTitle)
Workbooks.Open Filename:=sWb
sWb2 = ActiveWorkbook.Name

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Windows(sWb2).Activate
Rows("1:1").Select
ActiveSheet.Paste

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows(sWb2).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
ActiveSheet.Paste
Application.CutCopyMode = False

Windows(sWb2).Close False

Call FiscalMonth

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
LastRow = Range("C65536").End(xlUp).Row
Range("P2:P" & LastRow) = "Open"
Range("A2:A" & LastRow) = Format(Sheets("Quotes").Range("A2").Text, "mm/dd/yy")

Call addHyperlinks

Workbooks("Daily Log Template.xls").Sheets("Quotes").Columns.AutoFit

Call addFolders
Call addNotes
Call DailyLogSaveAs

Range("A1").Select
Application.CutCopyMode = False
Call AppendMonthlyLog
Call ExtractRepsList

Application.ScreenUpdating = True

Call funnyMsg

Exit Sub

err_handler:
Application.ScreenUpdating = True
MsgBox "File not selected or saved."

End Sub

Sub DailyLogSaveAs()

Dim FName As String
Dim FPath As String
Dim YearFolder As String
Dim MonthFolder As String

Application.ScreenUpdating = False
YearFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "yyyy")
MonthFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy")
FPath = "\\Deltarf\Reps\Daily Logs\" & YearFolder & "\" & MonthFolder
FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy")
ActiveWorkbook.Sheets("Quotes").Columns.AutoFit
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName & ".xls"
Application.ScreenUpdating = True

End Sub
Sub AppendMonthlyLog()
Dim FName As String
Dim wrk As Workbook
Dim wrkPath As String
Dim sht As Worksheet
Dim trg As Worksheet
Dim YearFolder As String
Dim MonthFolder As String
Dim rng As Range
Dim colCount As Integer
Dim MonthlyLog As String

Application.ScreenUpdating = False
YearFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "yyyy")
MonthFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy")
MonthlyLog = "Monthly Log " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy") & ".xls"
wrkPath = "\\Deltarf\Reps\Daily Logs\" & YearFolder & "\" & MonthFolder
FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Workbooks(FName).Activate
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 4).End(xlUp).Resize(, colCount))
Workbooks.Open "\\Deltarf\Reps\Daily Logs\" & YearFolder & "\" & MonthFolder & "\" & MonthlyLog
Set trg = Workbooks(MonthlyLog).Worksheets(1)
rng.Copy
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
trg.Range("R1") = Format(Workbooks(FName).Sheets("Quotes").Range("R1").Text, "mmm yy")
ActiveWorkbook.Sheets("Quotes").Columns.AutoFit
Workbooks(MonthlyLog).Save
Workbooks(MonthlyLog).Close

Set wrk = Nothing
Set sht = Nothing
Set trg = Nothing

Application.ScreenUpdating = True

End Sub
Sub FiscalMonth()
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim qDate As String
Dim fDate As String
Dim sDate As String
Dim eDate As String

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")

LogTemp.Activate
qDate = Format(LogTemp.Range("A2"), ("yymmdd"))
FisCal.Activate
FisCal.Range("A2").Select
Do Until IsEmpty(ActiveCell)
sDate = Format(ActiveCell.Offset(0, 1), ("yymmdd"))
eDate = Format(ActiveCell.Offset(0, 2), ("yymmdd"))
If qDate >= sDate And qDate <= eDate Then
LogTemp.Range("R1") = ActiveCell
End If
ActiveCell.Offset(1, 0).Select
Loop
LogTemp.Activate
LogTemp.Range("R1").Select
Selection.NumberFormat = "mmm yy"

Set FisCal = Nothing
Set LogTemp = Nothing

Application.ScreenUpdating = True

End Sub

Sub addHyperlinks()
Dim lrows As Long
Dim QHlink As Variant
Dim NHlink As Variant
Dim OHlink As Variant
Dim OHlink2 As Variant
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 11)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

QHlink = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Quotes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\Q " & QuoteNum & ".pdf"
Cells(lrows, 11).Value = "=hyperlink(""" & QHlink & """,""" & "Q " & QuoteNum & ".pdf" & """)"

NHlink = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\N " & QuoteNum & ".doc"
Cells(lrows, 12).Value = "=hyperlink(""" & NHlink & """,""" & "N " & QuoteNum & ".doc" & """)"

OHlink = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Orders\" & Format(LogTemp.Range("R1").Text, "yyyy") & "\S "
OHlink2 = "hyperlink(concatenate(""" & OHlink & """," & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "," & """.pdf""" & ")," & "concatenate(" & """S """ & "," & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "," & """.pdf""" & "))"
Cells(lrows, 15).Value = "=if(" & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "=0" & "," & Cells(lrows, 16).Address(rowabsolute:=False, columnabsolute:=True) & "," & OHlink2 & ")"

End With
Next lrows

Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing
Set QHlink = Nothing
Set NHlink = Nothing
Set OHlink = Nothing
Set OHlink2 = Nothing

Application.ScreenUpdating = True

End Sub
Sub addFolders()
Dim lrows As Long
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant
Dim QDestFldr As String
Dim NDestFldr As String
Dim ODestFldr As String

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 11)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

QDestFldr = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Quotes\" & Format(LogTemp.Range("R1").Text, "mmm yy")
If Dir(QDestFldr, vbDirectory) = "" Then
MkDir (QDestFldr)
End If
NDestFldr = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy")
If Dir(NDestFldr, vbDirectory) = "" Then
MkDir (NDestFldr)
End If
ODestFldr = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Orders\" & Format(LogTemp.Range("R1").Text, "yyyy")
If Dir(ODestFldr, vbDirectory) = "" Then
MkDir (ODestFldr)
End If
End With
Next lrows

Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing

Application.ScreenUpdating = True

End Sub
Sub addNotes()
Dim lrows As Long
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant
Dim NDestFile As String
Dim wdApp

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
Set wdApp = CreateObject("Word.Application")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 12)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

NDestFile = "\\deltarf\Reps\" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\" & Cells(lrows, 12)
If Dir(NDestFile) = "" Then
With wdApp
.documents.Add
.ActiveDocument.SaveAs Filename:=(NDestFile)
.ActiveDocument.Close
.Visible = False

End With
End If
End With
Next lrows

wdApp.Quit

Set wdApp = Nothing
Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing

Application.ScreenUpdating = True

End Sub

Sub funnyMsg()
MsgBox "We just created the daily log for " & Format(Sheets("Quotes").Range("A2").Text, "[$-F800]dddd, mmmm dd, yyyy") & ". We also updated the fiscal monthly log for " & Format(Sheets("Quotes").Range("R1").Text, "mmmm, yyyy") & ". Click OK and then update the Rep Logs by clicking the button that reads " & """" & "Click Here to Update Rep Logs" & """"
End Sub
Sub ExtractRepsList()
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim FName As String

FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Set LogTemp = Workbooks(FName).Sheets("Quotes")
Set FisCal = Workbooks(FName).Sheets("Fiscal Calendar")

LogTemp.Columns("D:D").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=FisCal.Range("D1"), Unique:=True

Set FisCal = Nothing
Set LogTemp = Nothing

End Sub
Sub AppendRepLogs()
Dim wrkPath As String
Dim trg As Worksheet
Dim RepFolder As String
Dim rng As Range
Dim RepLog As String
Dim RepNum As Variant
Dim Rep As Variant
Dim RepListCell As Variant
Dim RepListValue As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim FName As String

Application.ScreenUpdating = False
On Error GoTo err_handler

FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Set LogTemp = Workbooks(FName).Sheets("Quotes")
Set FisCal = Workbooks(FName).Sheets("Fiscal Calendar")
FisCal.Activate
FisCal.Select
FisCal.Range("D2").Select

Do Until IsEmpty(ActiveCell)
RepListCell = ActiveCell.Address
RepListValue = ActiveCell
RepNum = Replace(ActiveCell, "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)
RepFolder = "\\deltarf\reps\" & Rep
RepLog = RepNum & " Quote Log" & ".xls"
wrkPath = RepFolder & "\" & RepLog
Workbooks.Open wrkPath
Set trg = Workbooks(RepLog).Worksheets(1)
trg.Unprotect Password:="rr"
LogTemp.Activate
LogTemp.Select
Range("A2").Select
With ActiveSheet
Set rng = .UsedRange
With rng
.AutoFilter Field:=4, Criteria1:=RepListValue
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(1, 1)
LogTemp.Select
Range("A2").Select
Application.CutCopyMode = False
trg.Columns.AutoFit
trg.Protect Password:="rr"
'Workbooks(RepLog).Save
'Workbooks(RepLog).Close
End With
.AutoFilterMode = False
.UsedRange
End With
FisCal.Activate
FisCal.Range(RepListCell).Select
ActiveCell.Offset(1, 0).Select
Loop
Set trg = Nothing
Set rng = Nothing
Set RepNum = Nothing
Set Rep = Nothing
Set RepListCell = Nothing
Set RepListValue = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing

MsgBox "Rep Logs have been updated."
Application.ScreenUpdating = True
Exit Sub

err_handler:
Application.ScreenUpdating = True
MsgBox "We had a problem."
Set trg = Nothing
Set rng = Nothing
Set RepNum = Nothing
Set Rep = Nothing
Set RepListCell = Nothing
Set RepListValue = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing

End Sub
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
That's an awful lot of code which:
1. Is not in code tags, so hard to read.
2. Contains no comments of any kind indicating what is supposed to be happening
3. Is quite a lot to ask!

Having said that, I will say that you almost never need to select or activate anything in code in order to manipulate it. For example this:
Code: 
Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Windows(sWb2).Activate
Rows("1:1").Select
ActiveSheet.Paste
could be:
Code: 
Workbooks("Daily Log Template.xls").Sheets("Quotes").Rows(1).Copy Workbooks(sWb2).Sheets(1).Rows(1)

It's also easier if you use workbook and worksheet variables rather than storing sheet/book names as strings, especially if you are going to refer to them repeatedly.
 
Upvote 0
Thank you for the reply.

I think this is how to do code tags...

Code: 
Option Explicit
Sub FormatDailyLog()
Dim sFil As String
Dim sTitle As String
Dim sWb As String
Dim sWb2 As String
Dim LastRow As Long
Dim iFilterIndex As Integer

Application.ScreenUpdating = False
Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar").DirList
On Error GoTo err_handler
sFil = "Excel Files (*.xls),*.xls"
iFilterIndex = 1
sTitle = "Select File to Format"
sWb = Application.GetOpenFilename(sFil, iFilterIndex, sTitle)
Workbooks.Open Filename:=sWb
sWb2 = ActiveWorkbook.Name

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
Rows("1:1").Select
Application.CutCopyMode = False
Selection.Copy
Windows(sWb2).Activate
Rows("1:1").Select
ActiveSheet.Paste

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
Cells.Select
Application.CutCopyMode = False
Selection.Copy
Windows(sWb2).Activate
Cells.Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.Copy
Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
ActiveSheet.Paste
Application.CutCopyMode = False

Windows(sWb2).Close False

Call FiscalMonth

Workbooks("Daily Log Template.xls").Sheets("Quotes").Activate
LastRow = Range("C65536").End(xlUp).Row
Range("P2:P" & LastRow) = "Open"
Range("A2:A" & LastRow) = Format(Sheets("Quotes").Range("A2").Text, "mm/dd/yy")

Call addHyperlinks

Workbooks("Daily Log Template.xls").Sheets("Quotes").Columns.AutoFit

Call addFolders
Call addNotes
Call DailyLogSaveAs

Range("A1").Select
Application.CutCopyMode = False
Call AppendMonthlyLog
Call ExtractRepsList

Application.ScreenUpdating = True

Call funnyMsg

Exit Sub

err_handler:
Application.ScreenUpdating = True
MsgBox "File not selected or saved."

End Sub

Sub DailyLogSaveAs()

Dim FName As String
Dim FPath As String
Dim YearFolder As String
Dim MonthFolder As String

Application.ScreenUpdating = False
YearFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "yyyy")
MonthFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy")
FPath = "[URL="file://deltarf/Reps/Daily"][COLOR=#304c6c]\\Deltarf\Reps\Daily[/COLOR][/URL] Logs\" & YearFolder & "\" & MonthFolder
FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy")
ActiveWorkbook.Sheets("Quotes").Columns.AutoFit
ThisWorkbook.SaveAs Filename:=FPath & "\" & FName & ".xls"
Application.ScreenUpdating = True

End Sub
Sub AppendMonthlyLog()
Dim FName As String
Dim wrk As Workbook
Dim wrkPath As String
Dim sht As Worksheet
Dim trg As Worksheet
Dim YearFolder As String
Dim MonthFolder As String
Dim rng As Range
Dim colCount As Integer
Dim MonthlyLog As String

Application.ScreenUpdating = False
YearFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "yyyy")
MonthFolder = "Daily Logs - " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy")
MonthlyLog = "Monthly Log " & Format(Sheets("Quotes").Range("R1").Text, "mmm yy") & ".xls"
wrkPath = "[URL="file://deltarf/Reps/Daily"][COLOR=#304c6c]\\Deltarf\Reps\Daily[/COLOR][/URL] Logs\" & YearFolder & "\" & MonthFolder
FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Workbooks(FName).Activate
Set wrk = ActiveWorkbook
Set sht = wrk.Worksheets(1)
colCount = sht.Cells(1, 255).End(xlToLeft).Column
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(65536, 4).End(xlUp).Resize(, colCount))
Workbooks.Open "[URL="file://deltarf/Reps/Daily"][COLOR=#304c6c]\\Deltarf\Reps\Daily[/COLOR][/URL] Logs\" & YearFolder & "\" & MonthFolder & "\" & MonthlyLog
Set trg = Workbooks(MonthlyLog).Worksheets(1)
rng.Copy
trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(1, 1).Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
trg.Range("R1") = Format(Workbooks(FName).Sheets("Quotes").Range("R1").Text, "mmm yy")
ActiveWorkbook.Sheets("Quotes").Columns.AutoFit
Workbooks(MonthlyLog).Save
Workbooks(MonthlyLog).Close

Set wrk = Nothing
Set sht = Nothing
Set trg = Nothing

Application.ScreenUpdating = True

End Sub
Sub FiscalMonth()
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim qDate As String
Dim fDate As String
Dim sDate As String
Dim eDate As String

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")

LogTemp.Activate
qDate = Format(LogTemp.Range("A2"), ("yymmdd"))
FisCal.Activate
FisCal.Range("A2").Select
Do Until IsEmpty(ActiveCell)
sDate = Format(ActiveCell.Offset(0, 1), ("yymmdd"))
eDate = Format(ActiveCell.Offset(0, 2), ("yymmdd"))
If qDate >= sDate And qDate <= eDate Then
LogTemp.Range("R1") = ActiveCell
End If
ActiveCell.Offset(1, 0).Select
Loop
LogTemp.Activate
LogTemp.Range("R1").Select
Selection.NumberFormat = "mmm yy"

Set FisCal = Nothing
Set LogTemp = Nothing

Application.ScreenUpdating = True

End Sub

Sub addHyperlinks()
Dim lrows As Long
Dim QHlink As Variant
Dim NHlink As Variant
Dim OHlink As Variant
Dim OHlink2 As Variant
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 11)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

QHlink = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Quotes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\Q " & QuoteNum & ".pdf"
Cells(lrows, 11).Value = "=hyperlink(""" & QHlink & """,""" & "Q " & QuoteNum & ".pdf" & """)"

NHlink = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\N " & QuoteNum & ".doc"
Cells(lrows, 12).Value = "=hyperlink(""" & NHlink & """,""" & "N " & QuoteNum & ".doc" & """)"

OHlink = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Orders\" & Format(LogTemp.Range("R1").Text, "yyyy") & "\S "
OHlink2 = "hyperlink(concatenate(""" & OHlink & """," & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "," & """.pdf""" & ")," & "concatenate(" & """S """ & "," & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "," & """.pdf""" & "))"
Cells(lrows, 15).Value = "=if(" & Cells(lrows, 17).Address(rowabsolute:=False, columnabsolute:=True) & "=0" & "," & Cells(lrows, 16).Address(rowabsolute:=False, columnabsolute:=True) & "," & OHlink2 & ")"

End With
Next lrows

Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing
Set QHlink = Nothing
Set NHlink = Nothing
Set OHlink = Nothing
Set OHlink2 = Nothing

Application.ScreenUpdating = True

End Sub
Sub addFolders()
Dim lrows As Long
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant
Dim QDestFldr As String
Dim NDestFldr As String
Dim ODestFldr As String

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 11)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

QDestFldr = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Quotes\" & Format(LogTemp.Range("R1").Text, "mmm yy")
If Dir(QDestFldr, vbDirectory) = "" Then
MkDir (QDestFldr)
End If
NDestFldr = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy")
If Dir(NDestFldr, vbDirectory) = "" Then
MkDir (NDestFldr)
End If
ODestFldr = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Orders\" & Format(LogTemp.Range("R1").Text, "yyyy")
If Dir(ODestFldr, vbDirectory) = "" Then
MkDir (ODestFldr)
End If
End With
Next lrows

Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing

Application.ScreenUpdating = True

End Sub
Sub addNotes()
Dim lrows As Long
Dim Rep As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim RepNum As Variant
Dim QuoteNum As Variant
Dim NDestFile As String
Dim wdApp

Application.ScreenUpdating = False
Set LogTemp = Workbooks("Daily Log Template.xls").Sheets("Quotes")
Set FisCal = Workbooks("Daily Log Template.xls").Sheets("Fiscal Calendar")
Set wdApp = CreateObject("Word.Application")
LogTemp.Activate
For lrows = 2 To Range("A2").End(xlDown).Row
With Cells(lrows, 12)
QuoteNum = Val(Cells(lrows, 2))
RepNum = Replace(Cells(lrows, 4), "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)

NDestFile = "[URL="file://deltarf/Reps/"][COLOR=#304c6c]\\deltarf\Reps\[/COLOR][/URL]" & Rep & "\" & RepNum & " Notes\" & Format(LogTemp.Range("R1").Text, "mmm yy") & "\" & Cells(lrows, 12)
If Dir(NDestFile) = "" Then
With wdApp
.documents.Add
.ActiveDocument.SaveAs Filename:=(NDestFile)
.ActiveDocument.Close
.Visible = False

End With
End If
End With
Next lrows

wdApp.Quit

Set wdApp = Nothing
Set Rep = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing
Set RepNum = Nothing
Set QuoteNum = Nothing

Application.ScreenUpdating = True

End Sub

Sub funnyMsg()
MsgBox "We just created the daily log for " & Format(Sheets("Quotes").Range("A2").Text, "[$-F800]dddd, mmmm dd, yyyy") & ". We also updated the fiscal monthly log for " & Format(Sheets("Quotes").Range("R1").Text, "mmmm, yyyy") & ". Click OK and then update the Rep Logs by clicking the button that reads " & """" & "Click Here to Update Rep Logs" & """"
End Sub
Sub ExtractRepsList()
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim FName As String

FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Set LogTemp = Workbooks(FName).Sheets("Quotes")
Set FisCal = Workbooks(FName).Sheets("Fiscal Calendar")

LogTemp.Columns("D:D").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=FisCal.Range("D1"), Unique:=True

Set FisCal = Nothing
Set LogTemp = Nothing

End Sub
Sub AppendRepLogs()
Dim wrkPath As String
Dim trg As Worksheet
Dim RepFolder As String
Dim rng As Range
Dim RepLog As String
Dim RepNum As Variant
Dim Rep As Variant
Dim RepListCell As Variant
Dim RepListValue As Variant
Dim FisCal As Worksheet
Dim LogTemp As Worksheet
Dim FName As String

Application.ScreenUpdating = False
On Error GoTo err_handler

FName = "Daily Log " & Format(Sheets("Quotes").Range("A2").Text, "mm.dd.yy") & ".xls"
Set LogTemp = Workbooks(FName).Sheets("Quotes")
Set FisCal = Workbooks(FName).Sheets("Fiscal Calendar")
FisCal.Activate
FisCal.Select
FisCal.Range("D2").Select

Do Until IsEmpty(ActiveCell)
RepListCell = ActiveCell.Address
RepListValue = ActiveCell
RepNum = Replace(ActiveCell, "A", "")
Rep = WorksheetFunction.VLookup(RepNum, FisCal.Range("E:F"), 2, False)
RepFolder = "[URL="file://deltarf/reps/"][COLOR=#304c6c]\\deltarf\reps\[/COLOR][/URL]" & Rep
RepLog = RepNum & " Quote Log" & ".xls"
wrkPath = RepFolder & "\" & RepLog
Workbooks.Open wrkPath
Set trg = Workbooks(RepLog).Worksheets(1)
trg.Unprotect Password:="rr"
LogTemp.Activate
LogTemp.Select
Range("A2").Select
With ActiveSheet
Set rng = .UsedRange
With rng
.AutoFilter Field:=4, Criteria1:=RepListValue
.Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=trg.Cells(65536, 1).End(xlUp).Offset(1).Resize(1, 1)
LogTemp.Select
Range("A2").Select
Application.CutCopyMode = False
trg.Columns.AutoFit
trg.Protect Password:="rr"
'Workbooks(RepLog).Save
'Workbooks(RepLog).Close
End With
.AutoFilterMode = False
.UsedRange
End With
FisCal.Activate
FisCal.Range(RepListCell).Select
ActiveCell.Offset(1, 0).Select
Loop
Set trg = Nothing
Set rng = Nothing
Set RepNum = Nothing
Set Rep = Nothing
Set RepListCell = Nothing
Set RepListValue = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing

MsgBox "Rep Logs have been updated."
Application.ScreenUpdating = True
Exit Sub

err_handler:
Application.ScreenUpdating = True
MsgBox "We had a problem."
Set trg = Nothing
Set rng = Nothing
Set RepNum = Nothing
Set Rep = Nothing
Set RepListCell = Nothing
Set RepListValue = Nothing
Set FisCal = Nothing
Set LogTemp = Nothing

End Sub
 
Upvote 0
Great!

I'll clean it up per your recommendations, test it and post it with code comments...

Thanks again.

Rob
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Trying to improve quality of image on Email.
Replies
0
Views
65
Eric Penfold
E
A
  • Solved
3 way use button to run macro
Replies
2
Views
100
Aleytha
A
O
  • Question
Multiple VBA codes on sheet1
Replies
1
Views
174
skillilea
S
E
  • Question
This code is to put a excel range onto a email
Replies
3
Views
417
I_know_nuffin
I
V
  • Question
Excel VBA - How to modify my code to include a command that prints data to PDF
Replies
1
Views
115
VanGirl
V

Forum statistics

Threads
1,215,409
Messages
6,124,730
Members
449,185
Latest member
ekrause77

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top