✔ Programação GLOBAL®: VBA Excel - Juntando distintas planilhas - Combine worksheets in Excel and Kill all excel objects

VBA Excel - Juntando distintas planilhas - Combine worksheets in Excel and Kill all excel objects

| Blog Office VBA | Blog Excel | Blog Access |

Quando estamos trabalhando com várias planilhas, não raramente centenas delas, e precisamos elaborar uma análise, um relatório, importá-las para uma base de dados, etc...Tudo isso seria mais fácil se ao invés de termos centenas de arquivos, tivéssemos acesso a somente uma planilha contendo os dados de todas as demais. Sim, meus caros, nos pouparia muito tempo. E como sempre nos vem a pergunta: Como?

Segue:

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