Este fórum está sendo desativado

[Henrique1473]

Olá, alguém pode me ajudar a diminuir esse código para mim? Achei bem grande e acho que tem como deixar menor, porém não sei como fazer.

Funciona assim, tenho uma planilha com todos os meses, separados com 5 semanas cada, em outra aba tenho uma macro, no caso essa que colocarei abaixo que identifica através da célula B29 (29,2) o número da semana que vai de 1 a 5 e a célula B30 (30,2) que pega o mês, indo de 1 a 12. Nesse código só tem o mês de Janeiro, eu fiz esse mesmo código para todos os outros meses e ficou enorme.

'Janeiro

Application.ScreenUpdating = False

'Semana 1

' 29,2 é onde fica o n° da semana e 30,2 o n° mês

If Cells(29, 2) = "1" And Cells(30, 2) = "1" Then
Range("B17").Select 'B17 é o valor que será passado para outra aba
Selection.Copy
Sheets("Lucro por Mês-Ano").Select
Range("B39").Select 'é a célula onde sera colado o valor de B17
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B4").Select 'Apenas deixa essa célula selecionada
Unload UserForm6
Sheets("Lucro por Dia").Select
MsgBox "Valor registrado!", vbInformation, "Ganhos na Semana"
End If
'Semana 2
If Cells(29, 2) = "2" And Cells(30, 2) = "1" Then
Range("B17").Select
Selection.Copy
Sheets("Lucro por Mês-Ano").Select
Range("B40").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B4").Select
Unload UserForm6
Sheets("Lucro por Dia").Select
MsgBox "Valor registrado!", vbInformation, "Ganhos na Semana"
End If
'Semana 3
If Cells(29, 2) = "3" And Cells(30, 2) = "1" Then
Range("B17").Select
Selection.Copy
Sheets("Lucro por Mês-Ano").Select
Range("B41").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B4").Select
Unload UserForm6
Sheets("Lucro por Dia").Select
MsgBox "Valor registrado!", vbInformation, "Ganhos na Semana"
End If
'Semana 4
If Cells(29, 2) = "4" And Cells(30, 2) = "1" Then
Application.ScreenUpdating = True
Range("B17").Select
Selection.Copy
Sheets("Lucro por Mês-Ano").Select
Range("B42").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B4").Select
Unload UserForm6
Sheets("Lucro por Dia").Select
MsgBox "Valor registrado!", vbInformation, "Ganhos na Semana"
End If
'Semana 5
If Cells(29, 2) = "5" And Cells(30, 2) = "1" Then
Range("B17").Select
Selection.Copy
Sheets("Lucro por Mês-Ano").Select
Range("B43").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B4").Select
Unload UserForm6
Sheets("Lucro por Dia").Select
MsgBox "Valor registrado!", vbInformation, "Ganhos na Semana"
End If
Application.ScreenUpdating = True

[topscore]

Henrique1473

Coloquei no word explicando como fiz.
Avise se tiver dúvidas, resolva o tópico se o problema estiver resolvido.