Fóruns
Microsoft Excel - 2...
2024 - VBA & Macros
Simplificação de có...
 
Notifications
Clear all

Simplificação de código

 
2024 - VBA & Macros
Post Recente por guma 12 anos atrás
3 Posts
2 Usuários
0 Reactions
900 Visualizações
RSS
 guma
(@guma)
Posts: 135
Estimable Member
Topic starter
 

Bom Dia

Tem como simplificar este monstro???

Sub fMain()
    Dim lng As Long

    Dim wks1 As Worksheet
    Dim wks2 As Worksheet

    Set wks1 = ThisWorkbook.Sheets("BALANCETE ANUAL")
    Set wks2 = ThisWorkbook.Sheets("JAN")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "C") = wks2.Range("C" & nl)
wks1.Cells(lng, "D") = wks2.Range("D" & nl)
wks1.Cells(lng, "E") = wks2.Range("E" & nl)
wks1.Cells(lng, "F") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    
    Set wks2 = ThisWorkbook.Sheets("FEV")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "G") = wks2.Range("C" & nl)
wks1.Cells(lng, "H") = wks2.Range("D" & nl)
wks1.Cells(lng, "I") = wks2.Range("E" & nl)
wks1.Cells(lng, "J") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("MAR")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "K") = wks2.Range("C" & nl)
wks1.Cells(lng, "L") = wks2.Range("D" & nl)
wks1.Cells(lng, "M") = wks2.Range("E" & nl)
wks1.Cells(lng, "N") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("ABR")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "S") = wks2.Range("C" & nl)
wks1.Cells(lng, "T") = wks2.Range("D" & nl)
wks1.Cells(lng, "U") = wks2.Range("E" & nl)
wks1.Cells(lng, "V") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("MAI")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "W") = wks2.Range("C" & nl)
wks1.Cells(lng, "X") = wks2.Range("D" & nl)
wks1.Cells(lng, "Y") = wks2.Range("E" & nl)
wks1.Cells(lng, "Z") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("JUN")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "AA") = wks2.Range("C" & nl)
wks1.Cells(lng, "AB") = wks2.Range("D" & nl)
wks1.Cells(lng, "AC") = wks2.Range("E" & nl)
wks1.Cells(lng, "AD") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("JUL")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "AI") = wks2.Range("C" & nl)
wks1.Cells(lng, "AJ") = wks2.Range("D" & nl)
wks1.Cells(lng, "AK") = wks2.Range("E" & nl)
wks1.Cells(lng, "AL") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("AGO")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "AM") = wks2.Range("C" & nl)
wks1.Cells(lng, "AN") = wks2.Range("D" & nl)
wks1.Cells(lng, "AO") = wks2.Range("E" & nl)
wks1.Cells(lng, "AP") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("SET")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).RowRegras do fórum
Sua dúvida foi respondida? Marque como RESOLVIDO em seus tópicos, usando o botão com marca verde. 
Criar um novo tópico
Título:Cor do texto:                         
                         
                         
                         
                         

           Minúscula Pequena Normal Grande Enorme  

            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "AQ") = wks2.Range("C" & nl)
wks1.Cells(lng, "AR") = wks2.Range("D" & nl)
wks1.Cells(lng, "AS") = wks2.Range("E" & nl)
wks1.Cells(lng, "AT") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("OUT")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "AY") = wks2.Range("C" & nl)
wks1.Cells(lng, "AZ") = wks2.Range("D" & nl)
wks1.Cells(lng, "BA") = wks2.Range("E" & nl)
wks1.Cells(lng, "BB") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
    Set wks2 = ThisWorkbook.Sheets("NOV")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "BC") = wks2.Range("C" & nl)
wks1.Cells(lng, "BD") = wks2.Range("D" & nl)
wks1.Cells(lng, "BE") = wks2.Range("E" & nl)
wks1.Cells(lng, "BF") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
     Set wks2 = ThisWorkbook.Sheets("DEZ")

    With wks1
        For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            If Not IsError(Application.Match _
            (.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
'Identifica em qual linha foi encontrado o valor
nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                
wks1.Cells(lng, "BG") = wks2.Range("C" & nl)
wks1.Cells(lng, "BH") = wks2.Range("D" & nl)
wks1.Cells(lng, "BI") = wks2.Range("E" & nl)
wks1.Cells(lng, "BJ") = wks2.Range("F" & nl)
            
            Else
        
            End If
        Next lng
    End With
End Sub
 
Postado : 29/05/2013 5:55 am
Fernando Fernandes
 Fernando Fernandes
(@fernandofernandes)
Posts: 43750
Illustrious Member
 

Talvez assim

Sub fMainRes()
Dim lng As Long, y As Long, x As Long
Dim Aba(11) As String
Dim wks1 As Worksheet
Dim wks2 As Worksheet

Aba(0) = "JAN"
Aba(1) = "FEV"
Aba(2) = "MAR"
Aba(3) = "ABR"
Aba(4) = "MAI"
Aba(5) = "JUN"
Aba(6) = "JUL"
Aba(7) = "AGO"
Aba(8) = "SET"
Aba(9) = "OUT"
Aba(10) = "NOV"
Aba(11) = "DEZ"


Set wks1 = ThisWorkbook.Sheets("BALANCETE ANUAL")
y = -1
For x = 0 To 11
Set wks2 = ThisWorkbook.Sheets(Aba(x))
y = y + 4

MsgBox wks2.Name & " - - " & y
With wks1
    For lng = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
        If Not IsError(Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)) Then
            'Identifica em qual linha foi encontrado o valor
            nl = Application.Match(.Cells(lng, "A"), wks2.Columns("A"), 0)
                   
            wks1.Cells(lng, y) = wks2.Range("C" & nl)
            wks1.Cells(lng, y + 1) = wks2.Range("D" & nl)
            wks1.Cells(lng, y + 2) = wks2.Range("E" & nl)
            wks1.Cells(lng, y + 3) = wks2.Range("F" & nl)
        Else
        End If
    Next lng
End With
Next
End Sub

Existem mil maneiras de preparar Neston. Invente a sua!
http://www.youtube.com/ExpressoExcel

 
Postado : 29/05/2013 8:51 am
 guma
(@guma)
Posts: 135
Estimable Member
Topic starter
 

Boa tarde Reinaldo

Obrigado, tenho varias macros dessa forma e elas demoram uma eternidade para rodar.
vai me ajudar bastante.

Att.

 
Postado : 29/05/2013 12:37 pm
Forum Jump:
  Tópico Anterior
Próximo Tópico