Sub CopyFromWorksheets()
Dim wrk As Workbook
Dim sht As Worksheet
Dim trg As Worksheet
Dim rng As Range
Dim colCount As Long
'Dim sheetDelimiter As String
' Creates excel app object
Set objExcel = CreateObject("Excel.Application")
' Makes the excel invisible
objExcel.Visible = False
' Supress all display alerts
objExcel.DisplayAlerts = False
' Gets the complete path of the active excel sheet
strExcelFilePath = ActiveWorkbook.FullName
' Opens the excel file
Set objWorkbook = objExcel.Workbooks.Open(Trim(strExcelFilePath))
Set objWorkSheet = objWorkbook.Worksheets("Merge")
objWorkSheet.Activate
' Gets the count of column
Set objRange = objWorkbook.Worksheets("Merge")
numRowsCount = objRange.Evaluate("COUNTA(A1:A100)")
Worksheets("Merge").Activate
'sheetDelimiter = "######"
Set wrk = ActiveWorkbook 'Working in active workbook
For Each sht In wrk.Worksheets
If sht.Name = "Consolidated Backlog" Then
MsgBox "There is a worksheet called as 'Consolidated Backlog'." & vbCrLf & _
"Please remove or rename this worksheet since 'Consolidated Backlog' would be" & _
"the name of the result worksheet of this process.", vbOKOnly + vbExclamation, "Error"
Exit Sub
End If
Next sht
Application.ScreenUpdating = False
Set trg = wrk.Worksheets.Add(After:=wrk.Worksheets(wrk.Worksheets.Count))
trg.Name = "Consolidated Backlog"
'Get column headers from the first worksheet
'Column count first
Set sht = wrk.Worksheets(1)
colCount = 30
For cntLoop = 1 To numRowsCount
strSheetName = Trim(UCase(objExcel.Cells(cntLoop, 1).Value))
If Trim(strSheetName) = "" Then
Exit For
End If
If Trim(strSheetName) = "SHEET NAMES" Then
GoTo Continue
End If
For Each sht In wrk.Worksheets
'If worksheet in loop is the last one, stop execution (it is Master worksheet)
If sht.Index = wrk.Worksheets.Count Then Exit For
If strSheetName = UCase(sht.Name) Then
'Delimits the copied sheets with a string in a new row
With trg.Cells(1, 1).Resize(1, colCount)
.Value = sht.Cells(1, 1).Resize(1, colCount).Value
'Set font as bold
.Font.Bold = True
End With
trg.Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(1, 1).Value = sheetDelimiter
Set rng = sht.Range(sht.Cells(2, 1), sht.Cells(Rows.Count, 1).End(xlUp).Resize(, colCount))
rng.Copy trg.Cells(Rows.Count, 1).End(xlUp).Offset(1)
'Set objRange = sht.Range("A1").EntireColumn
'objRange.Insert (xlShiftToRight)
'sht.Range("A1") = sht.Name
End If
Next sht
Continue:
Next
objExcel.Quit
Set objWorkbook = Nothing
Set objExcel = Nothing
Set sht = Nothing
Set objWorkSheet = Nothing
Set objRange = Nothing
Set trg = Nothing
Set rng = Nothing
Application.ScreenUpdating = True
'create WMI object instance
Set objWMI = GetObject("winmgmts:")
If Not IsNull(objWMI) Then
'create object collection of Win32 processes
Set objProcList = objWMI.InstancesOf("win32_process")
For Each objProc In objProcList 'iterate through enumerated
If UCase(objProc.Name) = UCase(procName) Then
objProc.Terminate (0)
End If
Next
End If
Set objProcList = Nothing
Set objWMI = Nothing
End Sub
