Trouble understanding and modifying my array code

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,157
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I have a procedure using arrays that many people helped me create as I don't really understand them yet.

I am in the process of testing it and I have found an issue. The array inarr is the source of my data and I need column H from inarr to be copied to column K in the Wsdst worksheets. Can someone help me with the code to make this little adjustment please?


This is my procedure:

VBA Code:
Sub cmdCopy()
'On Error GoTo ErrorMsg
    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
    Dim inarr As Variant, lasttrack As Long, lastdst As Long
    Dim i As Long, kk As Long
        Application.ScreenUpdating = False
    Dim out1(1 To 1, 1 To 3) As Variant
    Dim out2(1 To 1, 1 To 10) As Variant
    
    '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
inarr = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting").DataBodyRange.Value

For i = 1 To UBound(inarr, 1)
If inarr(i, 1) = "" Or inarr(i, 5) = "" Or inarr(i, 6) = "" Then
            MsgBox "The Date, Service or Requesting Organisation has not been entered for every record in the table"
            Exit Sub
  End If
Next i
'For Each tblrow In tbl.ListRows
For i = 1 To UBound(inarr, 1)
       
        'Define combo as the month to be recorded in
'        Combo = tblrow.Range.Cells(1, 26).Value
        Combo = inarr(i, 26)
        'If column 8 for the row is blank...
'        If Not tblrow.Range(1, 8).Value = "" Then
        If Not inarr(i, 8) = "" Then
            'worker variable is defined as the value in column 8 of the row
            'worker = tblrow.Range.Cells(1, 8).Value
            worker = inarr(i, 8)
        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)
        ReportTracking = inarr(i, 39)
            Select Case inarr(i, 6)
'                    Select Case tblrow.Range.Cells(1, 6).Value
                Case "AW", "AWW", "AA", "ASC", "YR"
                    'DocYearName = tblrow.Range.Cells(1, 37).Value
                    DocYearName = inarr(i, 37)
                Case Else
                    'DocYearName = tblrow.Range.Cells(1, 36).Value
                    DocYearName = inarr(i, 36)
            End Select

            
        If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & "Work Allocation Sheets" & "\" & site & "\" & DocYearName & ".xlsm"
        If UnsafeToDelete = True Then Exit Sub
'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"
        If UnsafeToDelete = True Then Exit Sub
'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
        'Copy the pricing cells from the quoting tool to the allocation sheet for use in calculating late cancels
        Workbooks(DocYearName).Worksheets("sheet2").Range("A4:E12").Value = Data.Range("A4:E12").Value ' NOTE DATA DOESN'T SEEM TO BE DEFINED!!

        With wsTrack
           lasttrack = .Cells(Rows.Count, "A").End(xlUp).Row + 1
              '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
            .Range(.Cells(lasttrack, 1), .Cells(lasttrack, 1)) = inarr(i, 1)
            'this copies the YP name column in the tblCosting
'            tblrow.Range(, 4).Copy
            'this pastes it into column B of the report tracking file
            out1(1, 1) = inarr(i, 4)
'            .Range(.Cells(lasttrack, 2), .Cells(lasttrack, 2)) = inarr(i, 4)
               'this copies the YP name column in the tblCosting
'            tblrow.Range(, 5).Copy
            'this pastes it into column A of report tracking file
            out1(1, 2) = inarr(i, 5)
            out1(1, 3) = inarr(i, 8)
            .Range(.Cells(lasttrack, 2), .Cells(lasttrack, 4)) = out1 ' this saves 1 workhseet access

            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
          lastdst = .Cells(Rows.Count, "A").End(xlUp).Row + 1
          ' I am not sure what you are trying to do here but it can be improved
              
                '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
                
                For kk = 1 To 7
                out2(1, kk) = inarr(i, kk)         ' this save 7 workhseet acesses)
'                .Range(.Cells(lastdst, kk), .Cells(lastdst, kk)) = inarr(i, kk)
                Next kk
                ' this copies column 10 to column 8
                 out2(1, 8) = inarr(i, 10) ' this saves 1 access
'                .Range(.Cells(lastdst, 8), .Cells(lastdst, 8)) = inarr(i, 10)
                
                'This copies the first 7 columns, i.e. A:G, of the current row of the table to column A in the destination sheet.
                ' the comment doesn't seem t otie up wit the code here what are you doing??
                
'                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)"
               out2(1, 9) = "=IF(RC[-4]=""Activities"",0,RC[-1]*0.1)" 'this save 1 access
'                .Range(.Cells(lastdst, 9), .Cells(lastdst, 9)).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]"
                out2(1, 10) = "=RC[-1]+RC[-2]"
               ' .Range(.Cells(lastdst, 10), .Cells(lastdst, 10)).Formula = "=RC[-1]+RC[-2]"
               .Range(.Cells(lastdst, 1), .Cells(lastdst, 10)) = out2 ' this writes all 10 columns in one go
                'Adds currency formatting to total ex gst column
 '               .Columns(8).NumberFormat = "$#,##0.00" do this at the end
                'Adds Australian date format to date column
                '.Range("A:A").NumberFormat = "dd/mm/yyyy"
  
                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
                'sort procedure copied from vba
                'DO NOT DO THIS SORT ON EVERY ITERATION IT WILL BE MAJOR CAUSE OF YOUR TIME PROBLEM
        End With
'    Next tblrow
    Next i


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

'ErrorMsg:
'    Select Case Err.Number
'        Case 53
'            MsgBox "Enable macros needs to be selected"
'    End Select
End Sub

Thank you
 

Some videos you may like

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.

dpaton05

Well-known Member
Joined
Aug 14, 2018
Messages
2,157
Office Version
  1. 365
  2. 2016
Platform
  1. Windows
I worked it out. I just had to change
VBA Code:
Dim out2(1 To 1, 1 To 10) As Variant
to
VBA Code:
Dim out2(1 To 1, 1 To 11) As Variant

and
VBA Code:
.Range(.Cells(lastdst, 1), .Cells(lastdst, 10)) = out2
to
VBA Code:
.Range(.Cells(lastdst, 1), .Cells(lastdst, 11)) = out2

and add a line of code
VBA Code:
out2(1, 11) = inarr(i, 8)
above
VBA Code:
.Range(.Cells(lastdst, 1), .Cells(lastdst, 11)) = out2
 
Solution

Watch MrExcel Video

Forum statistics

Threads
1,128,129
Messages
5,628,865
Members
416,347
Latest member
AT2021

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
Top