dpaton05
Well-known Member
- Joined
- Aug 14, 2018
- Messages
- 2,392
- Office Version
- 365
- 2016
- Platform
- Windows
I have some code that copies rows from a table to a sheet in a workbook according to the date of the row. 2 rows in the table copy to 29 rows in the appropriate workbook and I have no idea why, can someone help me please?
Here is the copy code:
Here is the copy code:
Code:
Sub cmdCopy()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
Dim Combo As String, sht As Worksheet, tbl As ListObject
Dim LastRow As Long, lr As Long, DocYearName As String
Dim WbName As String, Workbook As Workbook
'assign values to variables
Set tbl = ThisWorkbook.Worksheets("Costing_tool").ListObjects("tblCosting")
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
'For every row, set value of combo to the name of the month that contains the date of the row
Combo = tblrow.Range.Cells(1, 26).Value
If tblrow.Range.Cells(1, 6).Value = "Ang Wes" Then
DocYearName = tblrow.Range.Cells(1, 37).Value
Else
DocYearName = tblrow.Range.Cells(1, 36).Value
End If
'If Workbooks(ThisWorkbook.Path & "\" & DocYearName).Open = True Then
'Workbooks(ThisWorkbook.Path & "\" & DocYearName).Close
'Else
'To open the workbook stored in the variable DocYearName
Workbooks.Open (ThisWorkbook.Path & "\" & DocYearName)
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
With wsDst
'This copies the first 10 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
tblrow.Range.Resize(, 10).Copy
'This pastes in the figures in the first 10 columns starting in column A
.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteFormulasAndNumberFormats
'Overwrites the numbers pasted to column I with a formula
.Range("I" & .Range("I" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[0]C[-4]=""*Activities"",0,RC[-1]*0.1)"
'Overwrites the numbers pasted to column J with a formula
.Range("J" & .Range("J" & .Rows.Count).End(xlUp).Row).Formula = "=IF(R[1]C[-5]=""*Activities"",RC[-2],RC[-1]+RC[-2])"
'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
.SetRange Range("A3:AK" & lr)
.header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
'save and close the workbook
ActiveWorkbook.Save
ActiveWorkbook.Close
'End If
Next tblrow
With Application
.CutCopyMode = False
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.EnableEvents = True
End With
End Sub