Olá, pessoal. Sou novo por aqui e dei uma olhadinha nos outros tópicos para ver se encontrava algo que pudesse me ajudar, mas não consegui encontrar nada... se já tiver algo me desculpe a repetição.
Estou querendo fazer uma planilha para um clínica. Essa planilha tem uma relação com os cooperados, que dela fazem parte. A macro irá pegar essa lista, criar uma guia para cada um dos nomes, fazer a formatação das planilhas criadas e por fim criar uma outra planilha com os dados consolidados de quanto entrou pra cada cooperado, quanto entrou pra clínica... enfim.
Essa macro que está aqui está quase perfeita. Tem uma guia chamada "Cooperado", que é a lista base, que acaba assumindo a mesma formatação que as outras planilhas criadas... Só que não é pra assumir essa formatação e eu não sei como resolver.
Obrigado pela ajuda.
_______________________________________________________//_________________________________________________
Option Explicit
Private Sub Criarplanilha()
Dim strCol As String
Dim strRow As String
Dim rngStart As Range
Dim rngEnd As Range
Dim rngCell As Range
Dim strWsName As String
Dim strSrcName As String
On Error GoTo ErrHnd
'setup column letter and first row number containing names
'column
strCol = "A"
'row (number is in double quotes)
strRow = "1"
'turn off screen updating to stop flicker & increase speed
Application.ScreenUpdating = False
'save this worksheet's name, so we can go back to it later
strSrcName = ActiveSheet.Name
'set start of data in selected column
Set rngStart = ActiveSheet.Range(strCol & strRow)
'find end of data in selected column
Set rngEnd = ActiveSheet.Range(strCol & CStr(Application.Rows.Count)) _
.End(xlUp)
'loop through cells in used range
For Each rngCell In ActiveSheet.Range(rngStart, rngEnd)
'ignore empty cells in range
If rngCell.Text <> "" Then
'get worksheet name
strWsName = rngCell.Text
'test if worksheet exists
On Error Resume Next
If Worksheets(strWsName) Is Nothing Then
'worksheet does not exist
'reinstate error handling
On Error GoTo ErrHnd
'create new sheet
Worksheets.Add After:=Worksheets(Worksheets.Count)
'name new sheet
Worksheets(Worksheets.Count).Name = strWsName
Else
'worksheet already exists
'reinstate error handling
On Error GoTo ErrHnd
End If
Call Formatarplanilha
End If
Next rngCell
'go back to the source worksheet
Worksheets(strSrcName).Activate
'reinstate screen updating
Application.ScreenUpdating = True
Exit Sub
'error handler
ErrHnd:
Err.Clear
'go back to the source worksheet
Worksheets(strSrcName).Activate
'reinstate screen updating
Application.ScreenUpdating = True
End Sub
Sub Formatarplanilha()
Call Criarplanilha
Range("A1").Select
ActiveCell.FormulaR1C1 = "Paciente"
Columns("A:A").ColumnWidth = 36.29
Range("B1").Select
Columns("B:B").ColumnWidth = 11.57
ActiveCell.FormulaR1C1 = "Data de " & Chr(10) & "pagamento"
Range("C1").Select
Columns("C:C").ColumnWidth = 10.86
ActiveCell.FormulaR1C1 = "Valor Pago" & Chr(10) & "(Paciente)"
Range("D1").Select
ActiveCell.FormulaR1C1 = "15% CBPS"
Range("E1").Select
Columns("E:E").ColumnWidth = 15.29
ActiveCell.FormulaR1C1 = "Valor Líquido" & Chr(10) & "(Cooperado)"
Range("B1:E1").Select
Range("A2:A30").Select
ActiveWorkbook.Names.Add Name:="Paciente", RefersToR1C1:= _
"=R2C1:R30C1"
Range("B2:B30").Select
ActiveWorkbook.Names.Add Name:="Data", RefersToR1C1:="=R2C2:R30C2"
Range("C2:C30").Select
ActiveWorkbook.Names.Add Name:="Vpac", RefersToR1C1:="=R2C3:R30C3"
Range("D2:D30").Select
ActiveWorkbook.Names.Add Name:="CBPS", RefersToR1C1:="=R2C4:R30C4"
Range("E2:E30").Select
ActiveWorkbook.Names.Add Name:="Vcoop", RefersToR1C1:="=R2C5:R30C5"
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlBottom
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Range("A1:E30").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("A1:E1").Select
Range("A1:E30").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlMedium
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Range("Paciente").Select
Selection.Font.Bold = True
Range("Data").Select
Selection.NumberFormat = "m/d/yyyy"
Range("Vpac").Select
Selection.NumberFormat = "$ #,##0.00"
Range("D2").Select
ActiveCell.FormulaR1C1 = "=RC[-1]*15%"
Range("D2").Select
Selection.AutoFill Destination:=Range("CBPS"), Type:=xlFillDefault
Range("CBPS").Select
Selection.NumberFormat = "$ #,##0.00"
Range("E2").Select
ActiveCell.FormulaR1C1 = "=RC[-2]-RC[-1]"
Range("E2").Select
Selection.AutoFill Destination:=Range("Vcoop"), Type:=xlFillDefault
Range("Vcoop").Select
Range("A1:E1").Select
Selection.Font.Bold = True
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent3
.TintAndShade = 0.799981688894314
.PatternTintAndShade = 0
End With
Range("A2:E30").Select
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MOD(LIN()+1;2)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.249946592608417
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
"=MOD(LIN( );2)"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = -0.14996795556505
End With
ActiveWindow.SmallScroll Down:=0
End Sub
Início 