[Python] Type mismatch nao anda

Claro, aqui está o código anterior: Option Explicit

Sub CriarRelatorio()
On Error GoTo ErrorHandler

' Desativa atualizações automáticas para melhorar o desempenho
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Dim wsObra As Worksheet, wsAceObra As Worksheet, wsRelatorio As Worksheet
Dim wsDiv As Worksheet, wsProduto As Worksheet

' Definir as folhas
Set wsObra = ThisWorkbook.Sheets("Obra")
Set wsAceObra = ThisWorkbook.Sheets("Aceobra")
Set wsDiv = ThisWorkbook.Sheets("Div")
Set wsProduto = ThisWorkbook.Sheets("Produto")

' Verificar se as folhas existem
If wsObra Is Nothing Or wsAceObra Is Nothing Or wsDiv Is Nothing Or wsProduto Is Nothing Then
MsgBox "Uma ou mais folhas não foram encontradas.", vbCritical
Exit Sub
End If

' Criar ou limpar a folha "Relatorio"
Set wsRelatorio = CriarOuLimparFolha("Relatorio")

' Criar cabeçalhos no relatório (com formatação verde)
CriarCabecalhos wsRelatorio

' Processar os dados conforme regras específicas
AdicionarDadosObra wsObra, wsRelatorio
ProcessarDadosComRegrasDinamicas wsObra, wsDiv, wsRelatorio
ProcessarDadosComRegrasAdicionais wsObra, wsAceObra, wsProduto, wsRelatorio

' Ajustar automaticamente as colunas do relatório
wsRelatorio.Columns.AutoFit

' Reativa atualizações automáticas
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True

MsgBox "Relatório criado com sucesso!", vbInformation
Exit Sub

ErrorHandler:
MsgBox "Ocorreu um erro: " & Err.Description, vbCritical
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

' Função para criar ou limpar a folha "Relatorio"
Private Function CriarOuLimparFolha(ByVal sheetName As String) As Worksheet
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Sheets(sheetName)
If ws Is Nothing Then
Set ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
ws.Name = sheetName
Else
ws.Cells.Clear
End If
On Error GoTo 0
Set CriarOuLimparFolha = ws
End Function

' Subrotina para criar cabeçalhos formatados
Private Sub CriarCabecalhos(ByVal wsRelatorio As Worksheet)
With wsRelatorio
' Primeiro conjunto de cabeçalhos
.Cells(1, 1).Value = "Cliente"
.Cells(1, 3).Value = "Obra"
.Range("A1:B1").Merge
.Range("C11").Merge

' Outros cabeçalhos...
.Cells(4, 1).Value = "Serviço Típico"
.Cells(4, 3).Value = "Colaborador"
.Range("A4:B4").Merge
.Range("C44").Merge

' Formatar células verdes
FormatarCelulasVerde .Range("A11")
FormatarCelulasVerde .Range("A44")
End With
End Sub

' Subrotina para adicionar dados da folha "Obra" ao relatório
Private Sub AdicionarDadosObra(ByVal wsObra As Worksheet, ByVal wsRelatorio As Worksheet)
Dim ultimaLinhaObra As Long
Dim i As Long
Dim valoresUnicos As Collection
Dim chave As String
Dim linhaAtualRelatorio As Long

' Encontrar a última linha da folha Obra
ultimaLinhaObra = wsObra.Cells(wsObra.Rows.Count, 3).End(xlUp).Row

' Iniciar a próxima linha no relatório após os cabeçalhos existentes
linhaAtualRelatorio = 2 ' Começando logo abaixo dos cabeçalhos

' Coleção para armazenar combinações únicas de valores
Set valoresUnicos = New Collection

' Percorrer todas as linhas da coluna 3 da folha Obra
For i = 2 To ultimaLinhaObra
chave = ""
On Error Resume Next
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 3).Value), "", wsObra.Cells(i, 3).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 2).Value), "", wsObra.Cells(i, 2).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 5).Value), "", wsObra.Cells(i, 5).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 6).Value), "", wsObra.Cells(i, 6).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 10).Value), "", wsObra.Cells(i, 10).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 11).Value), "", wsObra.Cells(i, 11).Value) & "|"
chave = chave & IIf(IsEmpty(wsObra.Cells(i, 12).Value), "", wsObra.Cells(i, 12).Value)

' Verificar se a combinação já existe na coleção
On Error Resume Next
valoresUnicos.Add chave, CStr(chave)
If Err.Number = 0 Then
' Se não ocorrer um erro, significa que a combinação é nova; adicionar ao relatório
With wsRelatorio
.Cells(linhaAtualRelatorio, 1).Value = IIf(IsEmpty(wsObra.Cells(i, 2).Value), "Não especificado", wsObra.Cells(i, 2).Value) ' Coluna 2
.Cells(linhaAtualRelatorio, 3).Value = IIf(IsEmpty(wsObra.Cells(i, 3).Value), "Não especificado", wsObra.Cells(i, 3).Value) ' Coluna 3
.Cells(linhaAtualRelatorio + 1, 1).Value = IIf(IsEmpty(wsObra.Cells(i, 5).Value), "Não especificado", wsObra.Cells(i, 5).Value) ' Coluna 5
.Cells(linhaAtualRelatorio + 1, 3).Value = IIf(IsEmpty(wsObra.Cells(i, 6).Value), "Não especificado", wsObra.Cells(i, 6).Value) ' Coluna 6
.Cells(linhaAtualRelatorio + 2, 1).Value = IIf(IsEmpty(wsObra.Cells(i, 10).Value), "Não especificado", wsObra.Cells(i, 10).Value) ' Coluna 10
.Cells(linhaAtualRelatorio + 2, 3).Value = IIf(IsEmpty(wsObra.Cells(i, 11).Value), "Não especificado", wsObra.Cells(i, 11).Value) ' Coluna 11
.Cells(linhaAtualRelatorio + 2, 4).Value = IIf(IsEmpty(wsObra.Cells(i, 12).Value), "Não especificado", wsObra.Cells(i, 12).Value) ' Coluna 12

' Mesclar células conforme necessário
.Range(.Cells(linhaAtualRelatorio, 1), .Cells(linhaAtualRelatorio, 2)).Merge
.Range(.Cells(linhaAtualRelatorio, 3), .Cells(linhaAtualRelatorio, 4)).Merge
.Range(.Cells(linhaAtualRelatorio + 1, 1), .Cells(linhaAtualRelatorio + 1, 2)).Merge
.Range(.Cells(linhaAtualRelatorio + 1, 3), .Cells(linhaAtualRelatorio + 1, 4)).Merge
.Range(.Cells(linhaAtualRelatorio + 2, 1), .Cells(linhaAtualRelatorio + 2, 2)).Merge

' Incrementar a linha atual do relatório
linhaAtualRelatorio = linhaAtualRelatorio + 3
End With
Err.Clear
End If
On Error GoTo 0
Next i
End Sub

' Subrotina para processar dados com regras dinâmicas
Private Sub ProcessarDadosComRegrasDinamicas(ByVal wsObra As Worksheet, ByVal wsDiv As Worksheet, ByVal wsRelatorio As Worksheet)
Dim dictColuna8 As Object
Dim ultimaLinhaObra As Long, ultimaLinhaDiv As Long
Dim linhaAtualRelatorio As Long
Dim somaValores As Double, valorMultiplicado As Double
Dim chave As Variant, valor As Variant
Dim i As Long, j As Long

' Inicializar dicionário para agrupar valores
Set dictColuna8 = CreateObject("Scripting.Dictionary")

' Encontrar a última linha das folhas Obra e Div
If wsObra Is Nothing Or wsDiv Is Nothing Then Exit Sub ' Verificar se as folhas existem
ultimaLinhaObra = wsObra.Cells(wsObra.Rows.Count, 8).End(xlUp).Row
ultimaLinhaDiv = wsDiv.Cells(wsDiv.Rows.Count, 20).End(xlUp).Row

If ultimaLinhaObra < 2 Or ultimaLinhaDiv < 2 Then Exit Sub ' Verificar se há dados suficientes

' Iniciar a próxima linha no relatório após os cabeçalhos existentes
linhaAtualRelatorio = 8

' Agrupar valores da coluna 8 (considerando coluna 9)
For i = 2 To ultimaLinhaObra
Dim chaveColuna8 As String
chaveColuna8 = CStr(IIf(IsEmpty(wsObra.Cells(i, 8).Value), "Vazio", wsObra.Cells(i, 8).Value)) ' Converter para string

' Verificar se a chave já existe
If Not dictColuna8.exists(chaveColuna8) Then
dictColuna8.Add chaveColuna8, New Collection
End If

' Adicionar valores da coluna 9 à coleção correspondente
On Error Resume Next
If IsNumeric(wsObra.Cells(i, 9).Value) Then
dictColuna8(chaveColuna8).Add CDbl(wsObra.Cells(i, 9).Value)
Else
dictColuna8(chaveColuna8).Add 0 ' Valor padrão caso seja inválido
End If
On Error GoTo 0
Next i

' Processar os valores agrupados da coluna 8
For Each chave In dictColuna8.keys
somaValores = 0

' Somar valores da coluna 9 para cada grupo de valores iguais na coluna 8
For Each valor In dictColuna8(chave)
On Error Resume Next
somaValores = somaValores + CDbl(valor)
If Err.Number <> 0 Then
somaValores = somaValores + 0 ' Valor padrão caso a conversão falhe
Err.Clear
End If
On Error GoTo 0
Next valor

' Multiplicar pela coluna 21 da folha Div, se houver correspondência na coluna 20
valorMultiplicado = "Não encontrado"
For j = 2 To ultimaLinhaDiv
If CStr(IIf(IsEmpty(wsDiv.Cells(j, 20).Value), "Vazio", wsDiv.Cells(j, 20).Value)) = CStr(chave) Then
If IsNumeric(wsDiv.Cells(j, 21).Value) Then
valorMultiplicado = somaValores * CDbl(wsDiv.Cells(j, 21).Value)
Else
valorMultiplicado = "Valor inválido"
End If
Exit For
End If
Next j

' Adicionar ao relatório
With wsRelatorio
.Cells(linhaAtualRelatorio, 1).Value = chave ' Coluna 8 da Obra
.Cells(linhaAtualRelatorio, 3).Value = somaValores ' Soma da coluna 9
.Cells(linhaAtualRelatorio, 4).Value = valorMultiplicado ' Resultado da multiplicação

' Mesclar células conforme necessário
.Range(.Cells(linhaAtualRelatorio, 1), .Cells(linhaAtualRelatorio, 2)).Merge

' Incrementar a linha atual do relatório
linhaAtualRelatorio = linhaAtualRelatorio + 1
End With
Next chave
End Sub

' Subrotina para processar dados com regras adicionais
Private Sub ProcessarDadosComRegrasAdicionais(ByVal wsObra As Worksheet, ByVal wsAceObra As Worksheet, ByVal wsProduto As Worksheet, ByVal wsRelatorio As Worksheet)
Dim ultimaLinhaObra As Long, ultimaLinhaAceObra As Long, ultimaLinhaProduto As Long
Dim linhaAtualRelatorio As Long
Dim valorMultiplicado As Double
Dim i As Long, j As Long, k As Long

' Encontrar as últimas linhas de cada folha
ultimaLinhaObra = wsObra.Cells(wsObra.Rows.Count, 3).End(xlUp).Row
ultimaLinhaAceObra = wsAceObra.Cells(wsAceObra.Rows.Count, 1).End(xlUp).Row
ultimaLinhaProduto = wsProduto.Cells(wsProduto.Rows.Count, 1).End(xlUp).Row

' Iniciar a próxima linha no relatório após os cabeçalhos existentes
linhaAtualRelatorio = 16

' Processar todos os registros da AceObra
For j = 2 To ultimaLinhaAceObra
' Transferir diretamente o valor da coluna 2 da AceObra para o relatório
wsRelatorio.Cells(linhaAtualRelatorio, 1).Value = IIf(IsEmpty(wsAceObra.Cells(j, 2).Value), "Não especificado", wsAceObra.Cells(j, 2).Value)

' Verificar correspondências na Obra e adicionar informações adicionais
For i = 2 To ultimaLinhaObra
If CStr(IIf(IsEmpty(wsObra.Cells(i, 3).Value), "Vazio", wsObra.Cells(i, 3).Value)) = CStr(IIf(IsEmpty(wsAceObra.Cells(j, 1).Value), "Vazio", wsAceObra.Cells(j, 1).Value)) Then
' Adicionar colunas 3 e 4 da AceObra ao Relatório
wsRelatorio.Cells(linhaAtualRelatorio, 2).Value = IIf(IsEmpty(wsAceObra.Cells(j, 3).Value), "Não especificado", wsAceObra.Cells(j, 3).Value)
wsRelatorio.Cells(linhaAtualRelatorio, 3).Value = IIf(IsEmpty(wsAceObra.Cells(j, 4).Value), 0, wsAceObra.Cells(j, 4).Value)

' Procurar no Produtos se o código da coluna 1 é igual ao código da coluna 2 da AceObra
Dim produtoEncontrado As Boolean
produtoEncontrado = False
For k = 2 To ultimaLinhaProduto
If CStr(IIf(IsEmpty(wsProduto.Cells(k, 1).Value), "Vazio", wsProduto.Cells(k, 1).Value)) = CStr(IIf(IsEmpty(wsAceObra.Cells(j, 2).Value), "Vazio", wsAceObra.Cells(j, 2).Value)) Then
If IsNumeric(wsAceObra.Cells(j, 4).Value) And IsNumeric(wsProduto.Cells(k, 9).Value) Then
valorMultiplicado = CDbl(wsAceObra.Cells(j, 4).Value) * CDbl(wsProduto.Cells(k, 9).Value)
wsRelatorio.Cells(linhaAtualRelatorio, 4).Value = valorMultiplicado
Else
wsRelatorio.Cells(linhaAtualRelatorio, 4).Value = "Cálculo impossível"
End If
produtoEncontrado = True
Exit For
End If
Next k

If Not produtoEncontrado Then
wsRelatorio.Cells(linhaAtualRelatorio, 4).Value = "Não encontrado"
End If

' Incrementar a linha atual do relatório
linhaAtualRelatorio = linhaAtualRelatorio + 1
Exit For ' Sair do loop interno após encontrar a primeira correspondência
End If
Next i

' Se não houver correspondência na Obra, ainda assim adicionar a linha com "Não encontrado"
If wsRelatorio.Cells(linhaAtualRelatorio - 1, 1).Value <> wsAceObra.Cells(j, 2).Value Then
wsRelatorio.Cells(linhaAtualRelatorio, 1).Value = IIf(IsEmpty(wsAceObra.Cells(j, 2).Value), "Não especificado", wsAceObra.Cells(j, 2).Value)
wsRelatorio.Cells(linhaAtualRelatorio, 2).Value = "Não encontrado"
wsRelatorio.Cells(linhaAtualRelatorio, 3).Value = IIf(IsEmpty(wsAceObra.Cells(j, 4).Value), 0, wsAceObra.Cells(j, 4).Value)
wsRelatorio.Cells(linhaAtualRelatorio, 4).Value = "Não encontrado"
linhaAtualRelatorio = linhaAtualRelatorio + 1
End If
Next j
End Sub

' Subrotina para formatar células em verde
Private Sub FormatarCelulasVerde(ByVal rng As Range)
With rng.Interior
.Pattern = xlSolid
.ThemeColor = xlThemeColorAccent6 ' Verde claro (tema padrão do Excel)
.TintAndShade = 0.399945066682943 ' Ajusta a intensidade da cor
End With
With rng.Font
.Bold = True
.Color = RGB(255, 255, 255) ' Texto branco
End With
End Sub

Continue reading...