How to record an object name as the procedure runs and then do something to all the objects at the end

dpaton05 · Nov 12, 2020

I have a procedure that copies data to different files. At the moment, it sorts the files each time a row is copied to it. This is very slow and I want to sort them at the end.

DocYearName is a variable that I have which stores the filename to be opened for each row.
Combo is a variable that stores the monthly sheet that the row needs to be put in
wsDst is a combination of the above 2 variables, ie,

VBA Code:

Set wsDst= Workbooks(DocYearName).Worksheets(Combo)

Many rows might need to be copied the same wsDst, or even different wsDst files depending on the date of them.

Instead of sorting them after each row is copied. Could someone help me with the vba code to sort each wsDst that has been opened at the end of the procedure please?

This is my code and I have included one row fron tblCosting.

VBA Code:

Sub cmdCopy()
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim lastrow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
        
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    'Check if each row has a date, service and requesting organisation
    For Each tblrow In tbl.ListRows
        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
        End If
    Next tblrow
    For Each tblrow In tbl.ListRows
        'Define combo as the month to be recorded in
        Combo = tblrow.Range.Cells(1, 26).Value

        ReportTracking = tblrow.Range.Cells(1, 39)
            Select Case Site
                Case "Western"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "AngWagga", "AngAlbury", "AngSouth Coast", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 37).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select
                Case "Riv"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "AngWestern", "AngWagga", "AngAlbury", "AngSouth Coast", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 42).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select

            End Select
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
        'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row

        With wsTrack
            'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
              'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 5).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
        End With
        With wsDst
                'This sets column width of request number column so it can be read and is not xxxxx
                .Columns("C:C").ColumnWidth = 8
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range.Resize(, 7).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range(, 10).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                
                'Overwrites the numbers pasted to column I with a formula
                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                'Overwrites the numbers pasted to column L with a formula
                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                'Adds currency formatting to total ex gst column
                .Columns(8).NumberFormat = "$#,##0.00"
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
        
                    'sort procedure copied from vba
                    wsDst.Sort.SortFields.Clear
                    wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                            With Workbooks(DocYearName).Worksheets(Combo).Sort
                                'set range to sort of A3 to AO
                                .SetRange Range("A3:AO" & lr)
                                .header = xlYes
                                .MatchCase = False
                                .Orientation = xlTopToBottom
                                .SortMethod = xlPinYin
                                .Apply
                            End With
        End With
    Next tblrow

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

CSS quoting tool 29.42.xlsm

A

B

C

D

E

F

G

J

K

L

M

N

O

P

Q

R

S

T

U

V

W

X

Y

Z

AA

AB

AC

AD

AE

AF

AG

AH

AI

AJ

AK

AL

AM

AN

AO

AP

4

Date

Purchase order #

Quote Ref #

Name

Service

Requesting Organisation

Caseworker Name

Price ex. GST

GST

Price inc. GST

Column5

Column6

Column7

Column8

Column9

Staff #

Kms

Add. Stops

Day Rate

extra pickup

$ 4 extra hrs

$ 4 kms

Max Pay

Month

Year

Combination

Document name

New doc name

10% increase

Activities

First Year

Second Year

Financial Year

ExternalAS

InternalAS

HoursRegister

ReportTracking

Column1

Column2

Column3

5

07/01/2021

51268

Supervised Transport

$55.80

2020 - 2021 Western CSS Work Allocation Sheet

2020 - 2021 Western Internal Work Allocation Sheet

2020 - 2021 Western Hours Register

2020 - 2021 Western Report Tracking

2020 - 2021 Riv Internal Work Allocation Sheet

Costing_tool

Cell Formulas
Range	Formula
K5	K5	=IF(E5="Activities",0,[Price ex. GST]*0.1)
L5	L5	=IF(E5="Activities",[@[Price ex. GST]],[GST]+[Price ex. GST])
Z5	Z5	=IF(MONTH(A5)=6,"June",TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "mmmm"))
AA5	AA5	=TEXT(DATE(YEAR(A5),IF(DAY(A5)<26,MONTH(A5),MONTH(A5)+1),1), "yyyy")
AD5	AD5	=CONCATENATE(AA5+1," - ",AA5+2)
AG5	AG5	=IF(MONTH(A5)<7,YEAR(A5)-1,YEAR(A5))
AH5	AH5	=IF(MONTH(A5)<7,YEAR(A5),YEAR(A5)+1)
AI5	AI5	=CONCATENATE(AG5," - ",AH5)
AJ5	AJ5	=CONCATENATE(AI5," ",Start_here!$H$9," CSS Work Allocation Sheet")
AK5	AK5	=CONCATENATE(AI5," ",Start_here!$H$9," Internal Work Allocation Sheet")
AL5	AL5	=CONCATENATE(AI5," ",Start_here!$H$9," Hours Register")
AM5	AM5	=CONCATENATE(AI5," ",Start_here!$H$9," Report Tracking")
AP5	AP5	=CONCATENATE(AI5," ","Riv Internal Work Allocation Sheet")

pbornemeier · Dec 11, 2020

I was not able to test this due to the requirements involved, but this should work.
Test on a copy of your workbooks, or step through slowly to be sure you are getting what you want.
Let me know if you have any questions.

VBA Code:

Option Explicit

Sub cmdCopy()
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim lastrow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
    
    'New ---------------------
    Dim oSD As Object
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare

        
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    'Check if each row has a date, service and requesting organisation
    For Each tblrow In tbl.ListRows
        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
        End If
    Next tblrow
    For Each tblrow In tbl.ListRows
        'Define combo as the month to be recorded in
        Combo = tblrow.Range.Cells(1, 26).Value

        ReportTracking = tblrow.Range.Cells(1, 39)
            Select Case Site
                Case "Western"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "AngWagga", "AngAlbury", "AngSouth Coast", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 37).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select
                Case "Riv"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "AngWestern", "AngWagga", "AngAlbury", "AngSouth Coast", "Yiri"
                            DocYearName = tblrow.Range.Cells(1, 42).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select

            End Select
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
        'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
        
        'New ------------------------------
        'Use Scripting Dictionary to hold each wsDst.
        oSD.Item(wsDst) = oSD.Item(wsDst) + 1

        With wsTrack
            'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
              'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 5).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteFormulasAndNumberFormats
        End With
        With wsDst
                'This sets column width of request number column so it can be read and is not xxxxx
                .Columns("C:C").ColumnWidth = 8
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range.Resize(, 7).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range(, 10).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
                
                'Overwrites the numbers pasted to column I with a formula
                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                'Overwrites the numbers pasted to column L with a formula
                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                'Adds currency formatting to total ex gst column
                .Columns(8).NumberFormat = "$#,##0.00"
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
        
        End With
    Next tblrow
    
    'New ------------------------------
    'Write to manipulable array
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
        
        'varTemp(1,x) holds the wsDst values
        'varTemp(2,x) holds the count of the number of times each wsDst was added
        
        'The workbooks that had data added to 1 or more worksheet(s) are open so iterate through them and sort
    
        'Sort each wsDst
        For lIndex = 1 To oSD.Count
        
            Set wsDst = varTemp(1, lIndex)
            'Get Last Row of wsDst
            With wsDst
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            End With
            'sort procedure copied from vba
            wsDst.Sort.SortFields.Clear
            wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Workbooks(DocYearName).Worksheets(Combo).Sort
                'set range to sort of A3 to AO
                .SetRange Range("A3:AO" & lr)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
    
        Next
        
        'Save & Close each workbook
        On Error Resume Next    'Might have had multiple worksheets in same workbook
        For lIndex = 1 To oSD.Count
            wsDst.Parent.Close SaveChanges:=True
        Next
        On Error GoTo 0
        
    End If

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
End Sub

dpaton05 · Dec 20, 2020

Thank you so much, that is perfect!!

pbornemeier · Dec 21, 2020

Glad to help.

dpaton05 · Dec 22, 2020

The version I provided the code for is the latest version of a tool I am developing. It is still in the testing phase and I was wondering if you could help me add the same dictionary feature to a earlier version please? This version is fully working and I just wanted to speed it up a little. I tried adding your code but seeing as the code structure is slightly different I think, it wouldn't work. This is the code I have:

VBA Code:

Sub cmdCopy()
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim lastrow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long, lrTrack As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
      
    'New ---------------------
    Dim oSD As Object
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
      
      
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    'Check if each row has a date, service and requesting organisation
    For Each tblrow In tbl.ListRows
        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
        End If
    Next tblrow
    For Each tblrow In tbl.ListRows
        'Define combo as the month to be recorded in
        Combo = tblrow.Range.Cells(1, 26).Value
        'If column 8 for the row is blank...
        If Not tblrow.Range(1, 8).Value = "" Then
            'worker variable is defined as the value in column 8 of the row
            worker = tblrow.Range.Cells(1, 8).Value
        Else
            'otherwise, "not allocated" is assigned to the worker variable.
            'this is used in the hours register to identify which sheet to place the hours in
            worker = "Not allocated"
        End If
        'defines HoursRegister as the hours register filename that is stored in column 38 for the row
        HoursRegister = tblrow.Range.Cells(1, 38)
        'defines ReportTracking as the report tracking filename that is stored in column 39 for the row
        ReportTracking = tblrow.Range.Cells(1, 39)
            Select Case Site
                Case "Wes"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "Ang Wag", "Ang A", "ASC", "Yir"
                            DocYearName = tblrow.Range.Cells(1, 37).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select
                Case "Riv"
                    Select Case tblrow.Range.Cells(1, 6).Value
                        Case "Ang Wes", "Ang Wag", "Ang A", "ASC", "Yir"
                            DocYearName = tblrow.Range.Cells(1, 42).Value
                        Case Else
                            DocYearName = tblrow.Range.Cells(1, 36).Value
                    End Select

            End Select
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
        'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
        'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)
        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
        lrTrack = wsTrack.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
        'With wsHours
              'this copies the date column in the tblCosting
            'HoursRow = .Range("A" & Rows.Count).End(xlUp).Row
            'tblrow.Range(, 1).Copy
            'this pastes it into column A of hours register file
            '.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
              'this copies the YP name column in the tblCosting
            'tblrow.Range(, 4).Copy
            'this pastes it into column B of hours register file
            '.Range("B" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the YP name column in the tblCosting
            'tblrow.Range(, 3).Copy
            'this pastes it into column A of hours register file
            '.Range("C" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
               'this copies the hours column in the tblCosting
            'tblrow.Range(, 9).Copy
            'this pastes it into column A of hours register file
            '.Range("D" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
        'End With

        'New ------------------------------
        'Use Scripting Dictionary to hold each wsDst.
        oSD.Item(wsDst) = oSD.Item(wsDst) + 1
       
       

        With wsTrack
            'format the date column as date format
            .Columns("A:A").NumberFormat = "dd/mm/yyyy"
            'this copies the date column in the tblCosting
            tblrow.Range(, 1).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
              'this copies the YP name column in the tblCosting
            tblrow.Range(, 4).Copy
            'this pastes it into column B of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteValues
               'this copies the YP name column in the tblCosting
            tblrow.Range(, 5).Copy
            'this pastes it into column A of report tracking file
            .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteValues

                lrTrack = wsTrack.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
                wsTrack.Sort.SortFields.Clear
                wsTrack.Sort.SortFields.Add Key:=Range("A2:A" & lrTrack), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        With Workbooks(ReportTracking).Worksheets(Combo).Sort
                            'set range to sort of A3 to AO
                            .SetRange Range("A1:I" & lrTrack)
                            .header = xlYes
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
           
        End With
        With wsDst
                'This sets column width of request number column so it can be read and is not xxxxx
                .Columns("C:C").ColumnWidth = 8
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range.Resize(, 7).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                tblrow.Range(, 10).Copy
                'This pastes in the figures in the first 7 columns starting in column A
                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
              
                'Overwrites the numbers pasted to column I with a formula
                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
                'Overwrites the numbers pasted to column L with a formula
                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
                'Adds currency formatting to total ex gst column
                .Columns(8).NumberFormat = "$#,##0.00"
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
        End With
    Next tblrow

                lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
                wsDst.Sort.SortFields.Clear
                wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
                        With Workbooks(DocYearName).Worksheets(Combo).Sort
                            'set range to sort of A3 to AO
                            .SetRange Range("A3:AO" & lr)
                            .header = xlYes
                            .MatchCase = False
                            .Orientation = xlTopToBottom
                            .SortMethod = xlPinYin
                            .Apply
                        End With
               



    'New ------------------------------
    'Write to manipulable array
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
            varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
       
        'varTemp(1,x) holds the wsDst values
        'varTemp(2,x) holds the count of the number of times each wsDst was added
       
        'The workbooks that had data added to 1 or more worksheet(s) are open so iterate through them and sort
   
        'Sort each wsDst
        For lIndex = 1 To oSD.Count
       
            Set wsDst = varTemp(1, lIndex)
            'Get Last Row of wsDst
            With wsDst
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            End With
            'sort procedure copied from vba
            wsDst.Sort.SortFields.Clear
            wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Workbooks(DocYearName).Worksheets(Combo).Sort
                'set range to sort of A3 to AO
                .SetRange Range("A3:AO" & lr)
                .header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
   
        Next
       
        'Save & Close each workbook
        On Error Resume Next    'Might have had multiple worksheets in same workbook
        For lIndex = 1 To oSD.Count
            wsDst.Parent.Close SaveChanges:=True
        Next
        On Error GoTo 0
       
    End If

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

.....and I get the error when it is running of Object doesn't support this property or method. I press debug and it highlights the following line of code.

VBA Code:

varTemp(1, lIndex) = varK(lIndex - 1)

Could you help me get this working please? I know I put the bits of code in the wrong spot or it needs to be slightly different but I don't know what the code needs to be.

pbornemeier · Dec 23, 2020

Commented out a bunch of your code (because I did not want to try to replicate your file and table setup), added a few lines to make a simplified version of it work (without the complexity), added a few debug statements to see what was going on, and made a few changes to make it work. Important changes to my (erroneous) original code marked with:
'CHANGED CODE NEXT LINE - (explanation)
in left column (for 2 lines of code and 1 comment).

I debated on changing the code to only store the name of the workbook/worksheet pair, but decided that since it seemed to be running well, there was no need. If code speed seems to be a problem it may be a bit quicker to change it to store the full FilePathNameExt!WorksheetName then split those parts when needed at the end to sort worksheets and save workbooks.

I had 2 errors in my original code (since I was unable to fully test it). Both corrected and noted below:

VBA Code:

Option Explicit

Sub cmdCopy()
    Dim wsDst As Worksheet, wsHours As Worksheet, wsTrack As Worksheet, worker As String, wsSrc As Worksheet, tblrow As ListRow
    Dim Combo As String, sht As Worksheet, tbl As ListObject
    Dim lastrow As Long, DocYearName As String, Site As String, lr As Long, HoursRow As Long, lrTrack As Long
    Dim RowColor As Long, w As Window, r As Long, HoursRegister As String, ReportTracking As String
        Application.ScreenUpdating = False
      
    'New ---------------------
    Dim oSD As Object
    Dim varK As Variant, varI As Variant, varTemp As Variant, lIndex As Long
    Set oSD = CreateObject("Scripting.Dictionary")
    oSD.CompareMode = vbTextCompare
    
'    TEMPORARY === Simplified tbl to hold filename and worksheet name
'    Wbk        sht
'    ---------- ------
'    Book4.xlsx Sheet1
'    Book4.xlsx Sheet2
'    Book4.xlsx Sheet3
'    Book2.xlsx Sheet1
'    Book2.xlsx Sheet2
'    Book2.xlsx Sheet3
'    Book3.xlsx Sheet1
'    Book3.xlsx Sheet2
'    Book3.xlsx Sheet3
    Dim sPath As String
    sPath = "J:\Shared Documents\Programming\Mr Excel\"
'    TEMPORARY === Simplified tbl to hold filename and worksheet name
      
    'assign values to variables
    Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
    Set sht = ThisWorkbook.Worksheets("Costing_tool")
    Site = ThisWorkbook.Worksheets("Start_here").Range("H9").Value
    'Check if each row has a date, service and requesting organisation
'    For Each tblrow In tbl.ListRows
'        If tblrow.Range.Cells(1, 1).Value = "" Or tblrow.Range.Cells(1, 5).Value = "" Or tblrow.Range.Cells(1, 6).Value = "" Then
'            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
'            Exit Sub
'        End If
'    Next tblrow
    For Each tblrow In tbl.ListRows
'        'Define combo as the month to be recorded in
'        Combo = tblrow.Range.Cells(1, 26).Value
'        'If column 8 for the row is blank...
'        If Not tblrow.Range(1, 8).Value = "" Then
'            'worker variable is defined as the value in column 8 of the row
'            worker = tblrow.Range.Cells(1, 8).Value
'        Else
'            'otherwise, "not allocated" is assigned to the worker variable.
'            'this is used in the hours register to identify which sheet to place the hours in
'            worker = "Not allocated"
'        End If
'        'defines HoursRegister as the hours register filename that is stored in column 38 for the row
'        HoursRegister = tblrow.Range.Cells(1, 38)
'        'defines ReportTracking as the report tracking filename that is stored in column 39 for the row
'        ReportTracking = tblrow.Range.Cells(1, 39)
'            Select Case Site
'                Case "Wes"
'                    Select Case tblrow.Range.Cells(1, 6).Value
'                        Case "Ang Wes", "Ang Wag", "Ang A", "ASC", "Yir"
'                            DocYearName = tblrow.Range.Cells(1, 37).Value
'                        Case Else
'                            DocYearName = tblrow.Range.Cells(1, 36).Value
'                    End Select
'                Case "Riv"
'                    Select Case tblrow.Range.Cells(1, 6).Value
'                        Case "Ang Wes", "Ang Wag", "Ang A", "ASC", "Yir"
'                            DocYearName = tblrow.Range.Cells(1, 42).Value
'                        Case Else
'                            DocYearName = tblrow.Range.Cells(1, 36).Value
'                    End Select
'
'            End Select
'        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & Site & "\" & DocYearName & ".xlsm"
'        'If Not isFileOpen(HoursRegister & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Hours Register" & "\" & Site & "\" & HoursRegister & ".xlsm"
'        If Not isFileOpen(ReportTracking & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Report Tracking" & "\" & Site & "\" & ReportTracking & ".xlsm"
'        'Set wsHours = Workbooks(HoursRegister).Worksheets(worker)

'    TEMPORARY === Assign values to DocYearName Combo
    DocYearName = tblrow.Range.Cells(1, 1).Value
    Combo = tblrow.Range.Cells(1, 2).Value
    'Debug.Print DocYearName, Combo
    If Not isFileOpen(DocYearName) Then Workbooks.Open sPath & DocYearName
'    TEMPORARY === Assign values to DocYearName Combo
    

        Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
        
'        Set wsTrack = Workbooks(ReportTracking).Worksheets(Combo)
'        lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
'        lrTrack = wsTrack.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
'        'With wsHours
'              'this copies the date column in the tblCosting
'            'HoursRow = .Range("A" & Rows.Count).End(xlUp).Row
'            'tblrow.Range(, 1).Copy
'            'this pastes it into column A of hours register file
'            '.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'              'this copies the YP name column in the tblCosting
'            'tblrow.Range(, 4).Copy
'            'this pastes it into column B of hours register file
'            '.Range("B" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'               'this copies the YP name column in the tblCosting
'            'tblrow.Range(, 3).Copy
'            'this pastes it into column A of hours register file
'            '.Range("C" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'               'this copies the hours column in the tblCosting
'            'tblrow.Range(, 9).Copy
'            'this pastes it into column A of hours register file
'            '.Range("D" & HoursRow).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'        'End With

        'New ------------------------------
        'Use Scripting Dictionary to hold each wsDst.
        oSD.Item(wsDst) = oSD.Item(wsDst) + 1
       
       

'        With wsTrack
'            'format the date column as date format
'            .Columns("A:A").NumberFormat = "dd/mm/yyyy"
'            'this copies the date column in the tblCosting
'            tblrow.Range(, 1).Copy
'            'this pastes it into column A of report tracking file
'            .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'              'this copies the YP name column in the tblCosting
'            tblrow.Range(, 4).Copy
'            'this pastes it into column B of report tracking file
'            .Range("A" & Rows.Count).End(xlUp).Offset(, 1).PasteSpecial xlPasteValues
'               'this copies the YP name column in the tblCosting
'            tblrow.Range(, 5).Copy
'            'this pastes it into column A of report tracking file
'            .Range("A" & Rows.Count).End(xlUp).Offset(, 2).PasteSpecial xlPasteValues
'
'                lrTrack = wsTrack.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
'                wsTrack.Sort.SortFields.Clear
'                wsTrack.Sort.SortFields.Add Key:=Range("A2:A" & lrTrack), _
'                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        With Workbooks(ReportTracking).Worksheets(Combo).Sort
'                            'set range to sort of A3 to AO
'                            .SetRange Range("A1:I" & lrTrack)
'                            .Header = xlYes
'                            .MatchCase = False
'                            .Orientation = xlTopToBottom
'                            .SortMethod = xlPinYin
'                            .Apply
'                        End With
'
'        End With
'        With wsDst
'                'This sets column width of request number column so it can be read and is not xxxxx
'                .Columns("C:C").ColumnWidth = 8
'                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
'                tblrow.Range.Resize(, 7).Copy
'                'This pastes in the figures in the first 7 columns starting in column A
'                .Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
'                tblrow.Range(, 10).Copy
'                'This pastes in the figures in the first 7 columns starting in column A
'                .Range("H" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
'
'                'Overwrites the numbers pasted to column I with a formula
'                .Range("I" & Rows.Count).End(xlUp).Offset(1).Formula = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)"
'                'Overwrites the numbers pasted to column L with a formula
'                .Range("J" & Rows.Count).End(xlUp).Offset(1).Formula = "=RC[-1]+RC[-2]"
'                'Adds currency formatting to total ex gst column
'                .Columns(8).NumberFormat = "$#,##0.00"
'                'Adds Australian date format to date column
'                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
'        End With
    Next tblrow

'                lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
'                wsDst.Sort.SortFields.Clear
'                wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
'                    SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
'                        With Workbooks(DocYearName).Worksheets(Combo).Sort
'                            'set range to sort of A3 to AO
'                            .SetRange Range("A3:AO" & lr)
'                            .Header = xlYes
'                            .MatchCase = False
'                            .Orientation = xlTopToBottom
'                            .SortMethod = xlPinYin
'                            .Apply
'                        End With
               



    'New ------------------------------
    'Write to manipulable array
    If oSD.Count > 0 Then
        ReDim varTemp(1 To 2, 1 To oSD.Count)
        varK = oSD.keys: varI = oSD.Items
        For lIndex = 1 To oSD.Count
'CHANGED CODE NEXT LINE - because varK is holding objects (worksheets) and needs Set for assignment
            Set varTemp(1, lIndex) = varK(lIndex - 1): varTemp(2, lIndex) = varI(lIndex - 1)
        Next
       
        'varTemp(1,x) holds the wsDst values
        'varTemp(2,x) holds the count of the number of times each wsDst was added
'CHANGED CODE NEXT LINE - replaced 'them' with 'changed worksheets' for clarity
        'The workbooks that had data added to 1 or more worksheet(s) are open so iterate
        '  through changed worksheets and sort
   
        'Sort each wsDst
        For lIndex = 1 To oSD.Count
       
            Set wsDst = varTemp(1, lIndex)
            
            'Get Last Row of wsDst
            With wsDst
                lr = .Cells(.Rows.Count, 1).End(xlUp).Row
            End With
            'Debug.Print lr, wsDst.Parent.CodeName, wsDst.Parent.Name, wsDst.CodeName
            'sort procedure copied from vba
            wsDst.Sort.SortFields.Clear
            wsDst.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            With Workbooks(DocYearName).Worksheets(Combo).Sort
                'set range to sort of A3 to AO
                .SetRange Range("A3:AO" & lr)
                .Header = xlYes
                .MatchCase = False
                .Orientation = xlTopToBottom
                .SortMethod = xlPinYin
                .Apply
            End With
   
        Next
       
        'Save & Close each workbook
        On Error Resume Next    'Might have had multiple worksheets in same workbook
        For lIndex = 1 To oSD.Count
'CHANGED CODE NEXT LINE - Added, so program would not just close the last wsDst 9 times
            Set wsDst = varTemp(1, lIndex)
            'Debug.Print wsDst.Parent.Name, wsDst.Name
            wsDst.Parent.Close SaveChanges:=True
        Next
        On Error GoTo 0
       
    End If

    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

'TEMPORARY
Function isFileOpen(sFilePathNameExt As String) As Boolean
    Dim wbk As Workbook
    Dim sFileNameExt As String
    
    sFileNameExt = Mid(sFilePathNameExt, InStrRev(sFilePathNameExt, "\") + 1)
    For Each wbk In Application.Workbooks
        If UCase(wbk.Name) = UCase(sFileNameExt) Then
            isFileOpen = True
            Exit For
        End If
    Next
End Function

How to record an object name as the procedure runs and then do something to all the objects at the end

dpaton05

Well-known Member

Excel Facts

pbornemeier

Well-known Member

dpaton05

Well-known Member

pbornemeier

Well-known Member

dpaton05

Well-known Member

pbornemeier

Well-known Member

Similar threads

Forum statistics

Share this page

How to record an object name as the procedure runs and then do something to all the objects at the end

dpaton05

Well-known Member

Excel Facts

pbornemeier

Well-known Member

dpaton05

Well-known Member

pbornemeier

Well-known Member

dpaton05

Well-known Member

pbornemeier

Well-known Member

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock