Boa tarde, amigos JSCOPA e Wagner!
Achei interessante esse seu problema e percebi que é um problema corriqueiro e portanto poderia ser bem útil fazer um código para condensar tabelas com linhas e colunas desnecessárias. Dá uma testada no código que fiz abaixo para irmos refinando se necessário...
Obs.:
- O código também copia da primeira tabela e cola valores e formatos. Então o código que vc já usa não seria mais necessário.[/*:m:v5gxzgz1]
- O conceito que usei não foi o de excluir colunas e linhas mas de unir ranges em que haja pelo menos um valor em cada linha/coluna (CONTAR.VAZIO) e depois copiá-los/colá-los no destino.[/*:m:v5gxzgz1][/list:u:v5gxzgz1]
Sub EnxugaDados()
Dim rgDados As Range, rgTít As Range, rgÚtil As Range, rgDestino As Range
Dim L As Range, rgL As Range, C As Range, rgC As Range
With Worksheets("servidorX")
Set rgDados = .Range("A7:Z384").Offset(1, 1)
Set rgDados = rgDados.Resize(rgDados.Rows.Count - 1, rgDados.Columns.Count - 1)
Set rgDestino = .Range("AU7:BR384")
End With
With Application.WorksheetFunction
For Each L In rgDados.Rows
If .CountBlank(L) < L.Columns.Count Then
If Not rgL Is Nothing Then Set rgL = Union(rgL, L) Else Set rgL = L
If Not rgTít Is Nothing Then Set rgTít = Union(rgTít, L.Cells(1).Offset(0, -1)) Else Set rgTít = L.Cells(1).Offset(0, -1)
End If
Next L
For Each C In rgDados.Columns
If .CountBlank(C) < C.Rows.Count Then
If Not rgC Is Nothing Then Set rgC = Union(rgC, C) Else Set rgC = C
If Not rgTít Is Nothing Then Set rgTít = Union(rgTít, C.Cells(1).Offset(-1, 0)) Else Set rgTít = C.Cells(1).Offset(-1, 0)
End If
Next C
End With
If (rgL Is Nothing) Or (rgC Is Nothing) Then Exit Sub
Set rgÚtil = Union(rgTít, rgDados.Cells(1, 1).Offset(-1, -1), Intersect(rgL, rgC))
With rgDestino
.Clear
rgÚtil.Copy
.Cells(1).PasteSpecial xlPasteValues
.Cells(1).PasteSpecial xlPasteFormats
End With
Application.CutCopyMode = False
Set rgDados = Nothing: Set rgTít = Nothing
Set rgÚtil = Nothing: Set rgDestino = Nothing
Set L = Nothing: Set rgL = Nothing
Set C = Nothing: Set rgC = Nothing
End Sub
Postado : 09/12/2019 12:22 pm