rod2009rod

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.

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 compactado. lottery21.rar

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

<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