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

Inline image 1

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

TagsVBA, Tips, dummy, dummies, row, last, cell, célula, dirty area, detect, detectar

Nenhum comentário:

Postar um comentário

diHITT - Notícias