dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,392
- Office Version
- 365
- 2016
- Platform
- Windows
I want to add a variable of a workbook.worksheet combo to an array. This is the code where it is defined.
My procedure will loop through rows in a table and depending on the date of the row, wsDst may be different. I have a for next loop that loops through each row in a table. As shown above, wsDst refers to the worksheet in the appropriate workbook and may be different on each iteration of a for next loop or for each row. On each iteration of the loop, I want to add the value stored in wsDst to an array if it is not already there.
After the loop has finished, I then want to sort each sheet in the array. These will be all the sheets in the financial year workbooks that have had data copied to them and will need sorting. This is instead of sorting the spreadsheet on each iteration. I only know how to make it sort on every iteration but since someone helped me change my procedure to arrays, I am not even sure how to do that. Can someone help me with the code to put the workbook/worksheet combos into an array if they do not exist there and then sort them at the end of the procedure please?
Here is my procedure.
VBA Code:
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
My procedure will loop through rows in a table and depending on the date of the row, wsDst may be different. I have a for next loop that loops through each row in a table. As shown above, wsDst refers to the worksheet in the appropriate workbook and may be different on each iteration of a for next loop or for each row. On each iteration of the loop, I want to add the value stored in wsDst to an array if it is not already there.
After the loop has finished, I then want to sort each sheet in the array. These will be all the sheets in the financial year workbooks that have had data copied to them and will need sorting. This is instead of sorting the spreadsheet on each iteration. I only know how to make it sort on every iteration but since someone helped me change my procedure to arrays, I am not even sure how to do that. Can someone help me with the code to put the workbook/worksheet combos into an array if they do not exist there and then sort them at the end of the procedure please?
Here 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
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 2) 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", "AWAG", "AA", "ASC", "Y"
'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
'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)
.Range(.Cells(lasttrack, 2), .Cells(lasttrack, 3)) = out1 ' this saves 1 workhseet access
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 sets column width of request number column so it can be read and is not xxxxx
' .Columns("C:C").ColumnWidth = 8 do this once at the end!!!
'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"
'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
With wsDst
lr = .Cells(Rows.Count, "A").End(xlUp).Row ' line added to make sure you sort the whole sheet if rows have been added
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=Range("A4:A" & lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Columns("C:C").ColumnWidth = 8
End With
With Workbooks(DocYearName).Worksheets(Combo)
lr = .Cells(Rows.Count, "A").End(xlUp).Row ' line added to make sure you sort the whole worksheet
'set range to sort of A3 to AO
.Sort.SortFields.Add Key:=Range("B4:B" & lr) ' line added since you hadn't put a sort column in I chose B!!!
.Sort.header = xlYes
.Sort.MatchCase = False
.Sort.Orientation = xlTopToBottom
.Sort.SortMethod = xlPinYin
.Sort.Apply
End With
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