VBA convertendo Data

Estou com um problema, no seguinte código. Toda vez que filtro para uma planilha, ele converte a data para o modelo americano. Podem me ajudar.

Private Sub TXT_Data_Change()

SUPLEMENTOS.Range("AX2").Value = UCase(TXT_Data.Value)
SUPLEMENTOS.Range("BE2").Value = UCase(CBX_Setor.Value)

Boas consegue deixar o ficheiro ou pelo menos o código completo?
Obrigado! :slight_smile:

Segue o código, ele é um pouco extenso.

Private Sub BT_buscar_Click()

Dim Base As Range, crt As Range
Dim A As Long

With Application
.ScreenUpdating = False

    'Check if have a information in box's
    If CBX_Setor.Value = "" Then
        MsgBox "Por favor, escolha um setor", vbInformation, "VBA Elis"
        Exit Sub
    End If
    
    'Run ("Mostrar_abas")
    
   'Clean the sheet notePad
    NotePad.Range("A1").CurrentRegion.Clear
                   
           'Get the data region
           A = BD_DADOS.Range("A1048576").End(xlUp).Row 'Coontador
           Set Base = BD_DADOS.Range("A1:I1" & A)
           Set crt = SUPLEMENTOS.Range("AW1:BE2") 'Critera

           'Filter the data in listbox
           Base.AdvancedFilter xlFilterCopy, crt, NotePad.Range("A1:I1")
            Run ("Consulta_Filtrada") 'Get data in listbox
            
  .ScreenUpdating = True

End With

'Zerar variaveis
A = 0
Set Base = Nothing
Set crt = Nothing

End Sub

Private Sub BT_Home_Click()

On Error Resume Next
Unload FRM_Consultas

End Sub

Private Sub BT_Imprimir_Click()

Dim i As Long

With Application
    .ScreenUpdating = False
    
        i = NotePad.Range("A1048576").End(xlUp).Row
            
            'Arrumar o Layout da planilha
            Call Layout_Imprimir(i)
            
            Unload FRM_Consultas
            Unload FRM_Inserir_Dados_Dobra
            NotePad.Range("A1:H" & i).Select
            ActiveWindow.SelectedSheets.PrintPreview
            FRM_Inserir_Dados_Dobra.Show (VBA.vbModeless)
            FRM_Consultas.Show (VBA.vbModeless)
    
            NotePad.Visible = 2
            
    i = 0
    
    .ScreenUpdating = True
End With

End Sub

Private Sub BT_LimparFiltros_Click()

On Error Resume Next

    CBX_Cliente.Value = ""
    CBX_Turno.Value = ""
    CBX_TipoItem.Value = ""
    TXT_Data.Value = ""
    CBX_Setor.Value = ""
    CBX_Setor.SetFocus
    SUPLEMENTOS.Range("AW2:BE2").Clear  'For filter data
    TXT_Registros.Value = ""
    
    ListBox1.Clear

End Sub

Private Sub BT_PDF_Click()

Dim i As Long

NotePad.Visible = -1

i = NotePad.Range("A1048576").End(xlUp).Row

With Application
    .ScreenUpdating = False
     
            'Arrumar o Layout da planilha
            Call Layout_Imprimir(i)
                
            NotePad.Select
            Range("A1:H" & i).Select
           
        
            Selection.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            ActiveWorkbook.Path & "\Pesquisa VBA Elis.pdf", Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=True, IncludeDocProperties:=True
            Application.PrintCommunication = True
            
            NotePad.Visible = 2
            
            MsgBox "Arquivo convertido para PDF. " & vbCrLf _
                    & "Local do arquivo: " & ActiveWorkbook.Path & "\Pesquisa VBA Elis.pdf", vbInformation, "VBA Elis"
    
    .ScreenUpdating = True
End With

NotePad.Visible = 2

i = 0

End Sub

Private Sub CBX_Setor_Change()

Dim contador As Integer, t As Integer
Dim Xlrow As Long, ln As Long
Dim Xlcol As Integer
Dim XlDataArray() As Variant

On Error GoTo Handle

'Clean the box's
FRM_Consultas.CBX_Cliente.Clear
FRM_Consultas.CBX_TipoItem.Clear
FRM_Consultas.CBX_Turno.Clear
FRM_Consultas.TXT_Data.Value = ""
    

'Load the itens for department choosen
Select Case CBX_Setor.Value
      
      Case "Calandra"
                         
                'Add Tipo de item na comboBox
                contador = SUPLEMENTOS.Range("C1048576").End(xlUp).Row
                 For t = 2 To contador
                   CBX_TipoItem.AddItem SUPLEMENTOS.Cells(t, 3).Value
                 Next t
          
      Case "Cobertor"
          
                'Add Tipo de item na comboBox
                contador = SUPLEMENTOS.Range("F1048576").End(xlUp).Row
                 For t = 2 To contador
                   CBX_TipoItem.AddItem SUPLEMENTOS.Cells(t, 6).Value
                 Next t
     
      Case "Dobra"
              
                 'Add Tipo de item na comboBox
                contador = SUPLEMENTOS.Range("D1048576").End(xlUp).Row
                 For t = 2 To contador
                   CBX_TipoItem.AddItem SUPLEMENTOS.Cells(t, 4).Value
                 Next t
  
      Case "Finisher"
        
                'Add Tipo de item na comboBox
                contador = SUPLEMENTOS.Range("E1048576").End(xlUp).Row
                 For t = 2 To contador
                   CBX_TipoItem.AddItem SUPLEMENTOS.Cells(t, 5).Value
                 Next t
                 
End Select
    

        t = 0 And contador = 0

        'Add shift in comboBox
        contador = SUPLEMENTOS.Range("B1048576").End(xlUp).Row
        For t = 2 To contador
          CBX_Turno.AddItem SUPLEMENTOS.Cells(t, 2).Value
        Next t
                    
        t = 0 And contador = 0
     
        'Add Clients in comboBox
        contador = SUPLEMENTOS.Range("A1048576").End(xlUp).Row
         For t = 2 To contador
           CBX_Cliente.AddItem SUPLEMENTOS.Cells(t, 1).Value
         Next t
         
         '**************************************************
         'Filter the information about department
         On Error Resume Next
         BD_DADOS.ShowAllData
         
         'Total registers in BD_DADOS
         i = BD_DADOS.Range("A1048576").End(xlUp).Row
         Xldepartment = Application.WorksheetFunction.CountIf _
         (BD_DADOS.Range("A1:I" & i), UCase(CBX_Setor.Value))
         
         'Resize array
         ReDim XlDataArray(1 To Xldepartment, 1 To 9)
         Xlrow = 1
         
         For Xlcol = 1 To 9 'Col
           For ln = 1 To i 'Row
              Check_Data = BD_DADOS.Range("I" & ln).Value ' Get value
              If Check_Data = UCase(CBX_Setor.Value) Or Check_Data = "SETOR" Then 'Check the info the department
                 XlDataArray(Xlrow, Xlcol) = BD_DADOS.Cells(ln, Xlcol).Value 'Get the value
                 Xlrow = Xlrow + 1 'Next row
              End If
           Next ln
           Xlrow = 1 'Restart the count rows
         Next Xlcol
     
     i = 0
     
     'Insert the informations in Notepad
     NotePad.Cells.Delete
     NotePad.Range("A1:I" & Xldepartment) = XlDataArray
     i = NotePad.Range("A1048576").End(xlUp).Row
     
     'Insert in listbox the data
     Call Dados_Consulta(i)
     
     'Clean the variables
     t = 0
     contador = 0
     Xlcol = 0
     Xlrow = 0
     ln = 0

  Exit Sub

Handle: MsgBox Err.Number & " - " & Err.Description, vbCritical + vbOKOnly, “VBA Elis”

t = 0
contador = 0
Xlcol = 0
Xlrow = 0
ln = 0

End Sub
Private Sub CBX_TipoItem_Change()

SUPLEMENTOS.Range("BB2").Value = UCase(CBX_TipoItem.Value)

End Sub

Private Sub CBX_Turno_Change()

SUPLEMENTOS.Range("BD2").Value = UCase(CBX_Turno.Value)
SUPLEMENTOS.Range("BE2").Value = UCase(CBX_Setor.Value)

End Sub

Private Sub CBX_Cliente_Change()

SUPLEMENTOS.Range("BC2").Value = UCase(CBX_Cliente.Value)
SUPLEMENTOS.Range("BE2").Value = UCase(CBX_Setor.Value)

End Sub

Private Sub Frame1_Click()

End Sub

Private Sub TXT_Data_Change()

SUPLEMENTOS.Range("AX2").Value = UCase(TXT_Data.Value)
SUPLEMENTOS.Range("BE2").Value = UCase(CBX_Setor.Value)

End Sub

Private Sub UserForm_Initialize()

Dim i As Long
Dim Base As Range
Dim Nome As String

On Error Resume Next

 'Inseri a cor no userform chamado (FRM_Inserir_Dados_Dobra)
 FRM_Consultas.BackColor = RGB(0, 164, 167)
 
 SUPLEMENTOS.Range("AW2:BE2").Clear  'For filter data
 
    'Inserir informações no comboBox
    CBX_Setor.AddItem "Calandra"
    CBX_Setor.AddItem "Cobertor"
    CBX_Setor.AddItem "Dobra"
    CBX_Setor.AddItem "Finisher"
    
     'Total registers in BD_DADOS
     i = Application.WorksheetFunction.CountA(BD_DADOS.Range("A:A"))

'CHeck information, because don't clean titles
If i < 2 Then
    i = 2
End If
    
Set Base = BD_DADOS.Range(BD_DADOS.Cells(2, 1), BD_DADOS.Cells(i, 9)) 'Use the Region
Nome = "'" & BD_DADOS.Name & "'!" 'Sheet name

    With FRM_Consultas.ListBox1
        .ColumnHeads = True
        .ColumnCount = 9
        .RowSource = Nome & Base.Address
        .TextAlign = fmTextAlignCenter
        .Font = 10
        '.ColumnWidths = "20,30,25,60,80,60,180,55"
    End With

'Conta o total de registros
If i < 2 Then
        FRM_Consultas.TXT_Registros.Value = 0
    Else
        FRM_Consultas.TXT_Registros.Value = FRM_Consultas.ListBox1.ListCount
End If

'Clean the variables
i = 0
Set Base = Nothing
Nome = Empty

End Sub

Já tive um problema parecido. Ocorria sempre que o dia era menor que 11. Inicialmente usei o FORMAT para data. Resolveu por um tempo. Depois deixei minha data como double no VBA.