Re: vba archiving old invoices working but slow, need to optimise
Quote from skywriter;771471What is,"'Trades.xlsm'!Invoices_Sheet_To_Default_View", you are using application.run with this as an argument?
Hi Skywriter, Thanks for your reply.
I've attached the three bits of code that are called from the original code on the loops:
1st resets the view,
2nd resizes the comments box
3rd moves the files in dropbox if there are any to be moved when the invoice is archived.
Is there anything in particular i appear to be doing wrong?
Code
Sub Invoices_Sheet_To_Default_View()'reset back to defaults
Worksheets("Invoices").Activate
ActiveSheet.Range("A1").Select
Rows("4:4").Select
Selection.AutoFilter
Cells.Select
Selection.EntireColumn.Hidden = False
Selection.EntireRow.Hidden = False
'create filter and filter items
Range("A4:X4").Select
Selection.AutoFilter
Range("A4").Select
'hide unused columns
'Clear print area and print page
ActiveSheet.PageSetup.PrintArea = ""
Range("C20000").End(xlUp).Offset(1, 0).Select
'Cells.Find(What:="END OF INVOICES", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, SearchFormat:=False).Activate
With Columns(5)
.Font.Name = "Courier"
.NumberFormat = "General"
.HorizontalAlignment = xlLeft
End With
With Columns(3)
.Font.Name = "Courier"
.NumberFormat = "General"
.HorizontalAlignment = xlLeft
End With
Columns(8).NumberFormat = "General"
Columns(9).NumberFormat = "dd/mm/yy;@"
Columns(13).NumberFormat = "dd/mm/yy;@"
Columns(14).NumberFormat = "dd/mm/yy;@"
Columns(15).NumberFormat = "dd/mm/yy;@"
Columns(16).NumberFormat = "dd/mm/yy;@"
Range("H1").Select
Selection.NumberFormat = "m/d/yyyy"
'ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, _
'IgnorePrintAreas:=False
ActiveSheet.Shapes("Rounded Rectangle 2").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 3").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 4").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 5").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 6").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 7").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 8").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 9").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 10").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 11").Visible = True
ActiveSheet.Shapes("Rounded Rectangle 16").Visible = True
'hide unused columns
' Columns("A:A").Select
'Selection.EntireColumn.Hidden = True
'Columns("J:K").Select
'Selection.EntireColumn.Hidden = True
Call Comments_Size_and_Position
End Sub
Display More
Code
Sub Comments_Size_and_Position()Dim cmt As Comment
For Each cmt In ActiveSheet.Comments
cmt.Shape.top = cmt.Parent.top + 5
cmt.Shape.Left = _
cmt.Parent.Offset(0, 1).Left + 5
Next
Dim MyComments As Comment
Dim lArea As Long
For Each MyComments In ActiveSheet.Comments
With MyComments
.Shape.TextFrame.AutoSize = True
If .Shape.Width > 300 Then
lArea = .Shape.Width * .Shape.Height
.Shape.Width = 200
' An adjustment factor of 1.1 seems to work ok.
.Shape.Height = (lArea / 200) * 1.1
End If
End With
Next ' comment
End Sub
Display More
Code
Sub Move_Job_Sheets_To_Archive_Folder()'This example move all PDF files from FromPath to ToPath.
'Note: It will create the folder ToPath for you without a date-time stamp
Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim FileExt As String
Dim FNames As String
FromPath = "C:\Dropbox\OCC\Job Sheets Dropbox\New Jobs To Add MACRO Folder\" '<< Change
ToPath = "C:\Dropbox\OCC\Job Sheets Dropbox\" '<< Change only the destination folder"
FileExt = "*.pdf" '<< Change
'You can use *.* for all files or *.doc for word files
If Right(FromPath, 1) <> "\" Then
FromPath = FromPath & "\"
End If
FNames = Dir(FromPath & FileExt)
If Len(FNames) = 0 Then
MsgBox "No files in " & FromPath
Exit Sub
End If
Set FSO = CreateObject("scripting.filesystemobject")
'FSO.CreateFolder (ToPath)'commented out as don't need to recreate folder
FSO.MoveFile Source:=FromPath & FileExt, Destination:=ToPath
MsgBox "You can find the files from " & FromPath & " in " & ToPath
End Sub
Sub Move_Job_Folder_To_Archive_Folder()
Dim FSO As Object
Set FSO = CreateObject("scripting.filesystemobject")
If DirExists("C:\Dropbox\OCC\Jobs\" & Left(ActiveCell.Offset(0, 2).Value, 7) & " - " & ActiveCell.Offset(0, 6).Value) Then
FSO.MoveFolder _
Source:="C:\Dropbox\OCC\Jobs\" & Left(ActiveCell.Offset(0, 2).Value, 7) & " - " & ActiveCell.Offset(0, 6).Value, _
Destination:="C:\Dropbox\OCC\Jobs\Archived Jobs\"
End If
End Sub
Function DirExists(sSDirectory As String) As Boolean
If Dir(sSDirectory, vbDirectory) <> "" Then DirExists = True
End Function
Display More