Option Explicit
Sub Macro1()
Dim wb As Workbook
Dim blnIsWBOpen As Boolean
Application.ScreenUpdating = False
For Each wb In Workbooks
If wb.Name = "test.xlsm" Then
blnIsWBOpen = True
Exit For
End If
Next wb
Application.ScreenUpdating = True
If blnIsWBOpen = False Then
MsgBox "File is not open"
Else
MsgBox "File is open"
End If
End Sub Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
Dim Combo As String, sht As Worksheet, tbl As ListObject
Dim lastrow As Long, DocYearName As String, lr As Long
Dim w As Window
Application.ScreenUpdating = False
'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
Next tblrow
For Each tblrow In tbl.ListRows
Combo = tblrow.Range.Cells(1, 26).Value
'lastrow = Worksheets(Combo).Cells(Rows.Count, "A").End(xlUp).Row + 1 'number of first empty row in column A of Combo
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
'Workbooks.Open ThisWorkbook.Path & "\" & DocYearName & ".xlsm"
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
With wsDst
'This copies the first 16 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
tblrow.Range.Resize(, 16).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
'ActiveWorkbook.Save
' ActiveWorkbook.Close
End With
Next tblrow
Application.CutCopyMode = False
Application.ScreenUpdating = True
Function isFileOpen(fileName As String) As Boolean
Dim b As Boolean: b = False
Dim w As Window
For Each w In Application.Windows
If w.Caption = fileName Then b = True
Next
isFileOpen = b
End Function
Sub test()
Dim wsDst As Worksheet, wsSrc As Worksheet, tblrow As ListRow
Dim Combo As String, sht As Worksheet, tbl As ListObject
Dim lastrow As Long, DocYearName As String, lr As Long
Dim w As Window
Application.ScreenUpdating = False
'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
Next tblrow
For Each tblrow In tbl.ListRows
Combo = tblrow.Range.Cells(1, 26).Value
'lastrow = Worksheets(Combo).Cells(Rows.Count, "A").End(xlUp).Row + 1 'number of first empty row in column A of Combo
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
[COLOR=#0000ff]If Not isFileOpen(DocYearName & ".xlsm") Then Workbooks.Open ThisWorkbook.Path & "\" & DocYearName & ".xlsm"
[/COLOR]
Set wsDst = Workbooks(DocYearName).Worksheets(Combo)
lr = wsDst.Cells.Find("*", , xlValues, , xlRows, xlPrevious).Row
With wsDst
'This copies the first 16 columns, i.e. A:J, of the current row of the table to column A in the destination sheet.
tblrow.Range.Resize(, 16).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
'ActiveWorkbook.Save
' ActiveWorkbook.Close
End With
Next tblrow
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
