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

VBA Excel - Detectar a última Célula da Planilha - Detecting a last cell

| Blog Office VBA | Blog Excel | Blog Access | 

Esse código é para iniciantes faixas brancas: Como identificar a última célula e portanto a última linha da planilha.

Planilhas constantemente manipuláveis, cujos os dados não são conexões em bases de dados, mas dados colados através de CTRL + V, tendem a deixar dirty areas. Estas acabam por dificultar a detecção da última célula. O exemplo abaixo é uma técnica para teste naquelas bases de dados enormes, com grandes quantidades de dados, acima de 100.000 linhas, as quais devem dar constantes dores de cabeça àqueles que ainda não dominam as técnicas de conexão do MS Excel com o MS Access.

CÓDIGO: 

Function LCell(ws As Worksheet) As Range
  Dim LRow&, LCol%

  On Error Resume Next

  With ws
    Let LRow& = .Cells.Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row
    Let LCol%   = .Cells.Find(What:="*", SearchDirection:=xlPrevious,  SearchOrder:=xlByColumns).Column
  End With

  Set LCell = ws.Cells(LRow&, LCol%)
End Function

Usando esta função:
A função LCell demonstrada aqui não pode ser usada diretamente na planilha, mas pode ser evocada a partir de outra SUB VBA, implemente o código conforme demonstrado abaixo:

CÓDIGO: 

Sub Identifica()
   MsgBox LCell(Sheet1).Row
End Sub

Ahhh, e sempre se pode melhorar:

Function LRow (Rg as Range) As Long

    Dim ix As Long

    Let ix = rg.parent.UsedRange.Row - 1 + rg.parent.UsedRange.Rows.Count 

    Let LRow = ix 

End Function

Reference:

Bob Umlas

Inspiration:

André Luiz Bernardes

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