Visual Basic Erro código VBA - Saindo caractere diferente

[rod2009rod]

<Dim fd As Office.FileDialog, fileName As String, curLine As String, rowCnt As Long
Dim fso As Object, obFile As Object, shData As Excel.Worksheet, shFill As Excel.Worksheet
Dim fillRow As Long, fillCol As Long

Private Sub btnFile_Click()

''== select text file
Call clearAllControls
Call deleteDataSheet
Call setFillSheet
Call clearFillArea

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
  .AllowMultiSelect = False
  .Title = "Please select a text file"
  .Filters.Clear
  .Filters.Add "text files", "*.txt"
  
   If fd.Show <> -1 Then  ''== no file selected
      Call clearAllControls
      MsgBox "No text file selected", vbCritical, "Status"
    Else
     txtFileName.Value = Trim(.SelectedItems(1)) ''== get name of selected text file
     Call verifyTextData
     
     If rowCnt < 1 Then
       MsgBox "No record found in text file", vbCritical, "Status - empty record"
       Call closeObjects
       Exit Sub
     End If
  End If
Application.ScreenUpdating = True

End With
Call closeObjects

End Sub

Function clearAllControls()
''== clear text box and combo boxes
txtFileName.Value = ""
cmbFrom.Clear
cmbTo.Clear


End Function
  
Function verifyTextData()
lbMsg.Caption = "Copying text file, Please wait ..."
fileName = txtFileName.Value
Application.ScreenUpdating = False
Call deleteDataSheet ''== delete old data
Call setDataSheet  ''== set data tab

Call setFillSheet ''set fill tab
shFill.Activate
Open fileName For Input As #1
rowCnt = 0
cardCnt = 0
ctr = 0
ind = 0

Do While Not EOF(1)
Line Input #1, curLine
sp = Split(curLine, " ")
rowCnt = rowCnt + 1

ctr = ctr + 1 ''control to check for six line item

If ctr = 1 Then
 cardCnt = cardCnt + 1 ''card counter
 
 cmbFrom.AddItem
 ind = cmbFrom.ListCount - 1
 
 cmbFrom.List(ind, 0) = cardCnt ''card number
 cmbFrom.List(ind, 1) = rowCnt ''first row
  
 cmbTo.AddItem
 cmbTo.List(ind, 0) = cardCnt ''card number
ElseIf ctr = 6 Then
 cmbTo.List(ind, 1) = rowCnt ''last  row
 ctr = 0
End If

shData.Range("A" & rowCnt).Value = sp(0)

shData.Range("B" & rowCnt).Value = sp(1)

shData.Range("C" & rowCnt).Value = sp(2)

shData.Range("D" & rowCnt).Value = sp(3)

shData.Range("E" & rowCnt).Value = sp(4)

shData.Range("F" & rowCnt).Value = sp(5)

shData.Range("G" & rowCnt).Value = sp(6)

Loop
 
 cmbTo.List(ind, 1) = rowCnt ''last  row
 
 Close #1
 
MsgBox "Completed copying text file", vbInformation
lbMsg.Caption = ""
End Function
Function deleteDataSheet()
On Error Resume Next
Application.DisplayAlerts = False
Worksheets("DB").Delete

End Function

Function setDataSheet()
Set shData = ActiveWorkbook.Sheets.Add(after:=Worksheets("Fill"))
shData.Name = "DB"
End Function

Function setFillSheet()
'On Error GoTo errFill
Set shFill = ActiveWorkbook.Worksheets("Fill")
Exit Function
errFill:
MsgBox "Fill sheet does not exists", vbCritical, "Error - Fill sheet"
End Function
Function closeObjects()
On Error Resume Next
Set fd = Nothing
Set fso = Nothing
Set obFile = Nothing

End Function

Private Sub btnMark_Click()
Call verifyPrintSetting
End Sub
Function verifyPrintSetting()
On Error GoTo errVer

If Len(Trim(txtFileName.Value)) = 0 Then
  MsgBox "Please select a text file using the above control", vbInformation
  Exit Function
End If

If Len(Trim(cmbFrom.Value)) = 0 Or Len(Trim(cmbTo.Value)) = 0 Then
   MsgBox "Please select the range of tickets to be printed", vbInformation, "Empty drop down field"
  Exit Function
  
End If
 
 
If Val(cmbFrom.Value) > Val(cmbTo.Value) Then
   MsgBox "'Ticket From' can not be greater than 'Ticket To'", vbInformation, "Invalid range of tickets"
  Exit Function
End If

Call arrangeSelection
Exit Function
errVer:
MsgBox Err.Description
End Function
Private Sub UserForm_Initialize()
Call deleteDataSheet
End Sub

Function arrangeSelection()

Set shData = ActiveWorkbook.Worksheets("DB")
Call setFillSheet
st = cmbFrom.List(cmbFrom.ListIndex, 1) ''start row position of from ticket
en = cmbTo.List(cmbTo.ListIndex, 1) ''end row position of to ticket
 
ctr = 0
pos = 0
''== read each row of record
Application.ScreenUpdating = False
 
For pos = st To en Step 1
ctr = ctr + 1 ''panel counter

If ctr = 1 Then ''new ticket
  Call clearFillArea
  
End If

Call fillTicket(pos, ctr)

If ctr = 6 Then ''print ticket and reset panel count
   ctr = 0
   lbMsg.Caption = "Printing ticket # " & (pos / 6)
   frmLottery.Repaint
   shFill.PrintOut Copies:=1
End If

Next pos

pos = pos - 1
If Int(pos / 6) <> (pos / 6) Then
    lbMsg.Caption = "Printing ticket # " & Int(pos / 6) + 1
   frmLottery.Repaint
   shFill.PrintOut Copies:=1

End If
lbMsg.Caption = ""
Application.ScreenUpdating = True
MsgBox "Completed printing tickets", vbInformation, "Status"
 
End Function

Function clearFillArea()
shFill.Range("A1:AT21").ClearContents

With shFill.Range("C6:AK21")
.Font.Name = "Wingdings"
.Font.Size = 14
.Font.Color = vbBlack

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
''.Interior.Color = vbWhite
End With
End Function
Function refillNumbers()

End Function
Function fillTicket(rowPos, panelPos)

''= panelPos is panel code 1 to 6
''== rowPos is the row position of current record in data tab

''==Number 1 of selected row
num1 = shData.Range("A" & rowPos).Value
''read the row position of selected number in fill sheet
 Call getFillRowCol(num1, panelPos)

''==Number 2 of selected row
num2 = shData.Range("B" & rowPos).Value
 Call getFillRowCol(num2, panelPos)
 
''==Number 3 of selected row
num3 = shData.Range("C" & rowPos).Value
Call getFillRowCol(num3, panelPos)

''==Number 4 of selected row
num4 = shData.Range("D" & rowPos).Value
Call getFillRowCol(num4, panelPos)

''==Number 5 of selected row
num5 = shData.Range("E" & rowPos).Value
Call getFillRowCol(num5, panelPos)



''==Number 6 of selected row
num6 = shData.Range("F" & rowPos).Value
Call LuckyStarFillRowCol(num6, panelPos)

''==Number 7 of selected row
num7 = shData.Range("G" & rowPos).Value
Call LuckyStarFillRowCol(num7, panelPos)
 
End Function

Function getFillRowCol(recNumber, panelPos) As Long
''== recNumber - split number of a record
''== panel position of selected number / row

  fillRow = 0
  fillCol = 0
  
If recNumber = 1 Or recNumber = 2 Then
  fillRow = 6
  fillCol = 4 + recNumber
  
 ElseIf recNumber >= 3 And recNumber <= 8 Then
  fillRow = 7
  fillCol = recNumber - 2

 ElseIf recNumber >= 9 And recNumber <= 14 Then
  fillRow = 8
  fillCol = recNumber - 8

 ElseIf recNumber >= 15 And recNumber <= 20 Then
  fillRow = 9
  fillCol = recNumber - 14

 ElseIf recNumber >= 21 And recNumber <= 26 Then
  fillRow = 10
  fillCol = recNumber - 20

 ElseIf recNumber >= 27 And recNumber <= 32 Then
  fillRow = 11
  fillCol = recNumber - 26

 ElseIf recNumber >= 33 And recNumber <= 38 Then
  fillRow = 12
  fillCol = recNumber - 32

 ElseIf recNumber >= 39 And recNumber <= 44 Then
  fillRow = 13
  fillCol = recNumber - 38

 ElseIf recNumber >= 45 And recNumber <= 50 Then
  fillRow = 14
  fillCol = recNumber - 44

End If

''shift 2 first column (A and B)

''Adust the number of columns to be skiped depneds of panel selected
'''Panle 1 - no change, panel 2- 6 columns are skipped and so on.
''Plus the actual position of selected number in the current panel

 fillCol = 2 + ((panelPos - 1) * 6) + fillCol
''MsgBox " recNumber  = " & recNumber & " fill row " & fillRow & " col " & fillCol
 Call markTicketBlack
 
End Function

Function LuckyStarFillRowCol(recNumber, panelPos) As Long
''== recNumber - split number of a record
''== panel position of selected number / row

  fillRow = 0
  fillCol = 0
  
If recNumber >= 1 And recNumber <= 6 Then
  
  fillRow = 16
  fillCol = recNumber
  
 ElseIf recNumber >= 7 And recNumber <= 12 Then
  
  fillRow = 17
  fillCol = recNumber - 6

End If
 
 fillCol = 2 + ((panelPos - 1) * 6) + fillCol
 
 Call markTicketBlack
 
End Function
Function markTicketBlack()

With shFill.Cells(fillRow, fillCol)
   .Value = "n"
End With

End Function

''== Below code must be placed in a module
Sub fnLoadForm(btn As IRibbonControl)
frmLottery.Show
End Sub>

Boa Noite!

 

Tenho uma planilha utilizada para impressão de alguns cartões de números (loteria), só que está apresentando um erro. Ao imprimir no cartão, está saindo a letra "n" no lugar da marcação do número, conforme print em anexo.

 

Um profissional que não tenho mais o contato foi quem criou o código VBA para mim. Acredito que exista algumas macros bloqueadas e que não consigo ter acesso.

 

Por favor, se alguém conseguir me ajudar, agradeço.

 

Segue arquivos em anexo para análise.

 

Planilha.xlsx

[Basole]

Experimente esta alteracão:

 

Function clearFillArea()
shFill.Range("A1:AT21").ClearContents

With shFill.Range("C6:AM21")
.Font.Name = "Wingdings"
.Font.Size = 14
.Font.Color = vbBlack

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
''.Interior.Color = vbWhite
End With
End Function

 

[rod2009rod]

54 minutos atrás, Basole disse:

Experimente esta alteracão:

 

Function clearFillArea()
shFill.Range("A1:AT21").ClearContents

With shFill.Range("C6:AM21")
.Font.Name = "Wingdings"
.Font.Size = 14
.Font.Color = vbBlack

.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
''.Interior.Color = vbWhite
End With
End Function

 

Bom dia Basole!

 

Tudo bem?

 

Obrigado pela resposta. Fiz a alteração que você mencionou, mas ainda consta o erro, conforme print. Nos campos onde está saindo este "n", deveria sair colorido de preto igual aos demais. 

 

Se você puder ainda me ajudar, estou anexando um arquivo .txt que consta as marcações que deverão ser impressas. 

 

Na planilha, existe uma aba chamada tickets. Clique nela e depois em Mark Tickets. Vai abrir a tela pra você puxar o arquivo  .txt. Gere o cartão de número 2 em diante e verás que a letra "n" ainda permanece.

 

 

euro190 (1).txt

[Basole]

@rod2009rod a planilha que voce anexou, esta no formato *xlsx, por tanto não contem as macros e nem a tela citada. 

 

*Compacte o seu aquivo na extencão *.xlsm, para conseguir anexar aqui no forum.  

[rod2009rod]

1 minuto atrás, Basole disse:

@rod2009rod a planilha que voce anexou, esta no formato *xlsx, por tanto não contem as macros e nem a tela citada. 

 

*Compacte o seu aquivo na extencão *.xlsm, para conseguir anexar aqui no forum.  

 

Basole,

 

Segue o arquivo compactado.

lottery21.rar

[Basole]

@rod2009rod nos testes que fiz com o arquivo txt  "euro190 (1)", que enviou, nao apresentou esta inconsistencia.

 

De qualquer forma, experimente alterar tambem esta linha na funcao clearFillArea dentro do formulario (userForm)

 

With shFill.Range("C6:AM21")

 

[rod2009rod]

1 hora atrás, Basole disse:

@rod2009rod nos testes que fiz com o arquivo txt  "euro190 (1)", que enviou, nao apresentou esta inconsistencia.

 

De qualquer forma, experimente alterar tambem esta linha na funcao clearFillArea dentro do formulario (userForm)

 

With shFill.Range("C6:AM21")

 

Basole,

 

Obrigado pela sua ajuda!

 

Não está dando certo. Quando eu faço uma depuração parcial, ele retorna com uma mensagem de erro na função clearFillArea, conforme print.

[Basole]

Segue o arquivo com as alteracoes indicadas no meu post anterior

 

lottery21.zip

[rod2009rod]

40 minutos atrás, Basole disse:

Segue o arquivo com as alteracoes indicadas no meu post anterior

 

lottery21.zip 300 kB · 1 download

Basole,

 

Obrigado pelo envio do arquivo. Infelizmente, ainda está aparecendo a letra "n" na planilha.

 

Realmente, não sei o que pode estar acontecendo. Solicitei a um amigo para fazer um teste abrindo e executando o arquivo e ocorreu a mesma coisa.