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

Reference:

Aditya Kalra

Inspiration:

André Luiz Bernardes

Tags: VBA, Tips, dummy, dummies, row, last, cell, célula, dirty area, detect, detectar