Boa tarde!!

Favor ler o tópico:
http://support.microsoft.com/kb/262441/pt-br

Caso contrário poste seu arquivo para que o pessoal possa ajuda-lo.
Att

Boa tarde!

Ale, o meu excel é 2010 e a solução "Private Declare Function ReleaseCapture Lib "user32" Alias _
"ReleaseCapture" () As Long" dá erro.

estou disponibilizando os arquivos

Laeoli,

Boa Noite!

Veja se assim resolve.

Morel, Boa Noite!

Obrigado pela ajuda. O problema sumiu, porém o frmEng pega informações do Banco da Engenharia e descarrega no frm Entradas, no txtCliente, txt referencia, txt carga minina e txt tempo de forno e isto não ocorreu.

obs.: O frmEng é uma opção do usuário ao captar dados pré cadastrados ou usar no manual.

Valew!

Ok. Entendi mais ou menos a lógica do seu programa. Como o formulário frmEng descarrega as informações capturadas do Banco da Engenharia nos controles do frm Entradas? É quando se clica no botão Voltar? Pergunto isso porque não vi como isso acontece. As rotinas que estão associadas ao botão Voltar não fazem isso.

Quando fiz os primeiros testes, vi que quando clicava nesse botão, o seu código tenta carregar o UserForm4 novamente, sendo que ele já estava carregado. Isso fez com que surgisse o erro relatado por você. O que fiz, quando o formulário (UserForm4) é carregado, foi atribuir um flag que é checado quando se pretende carregar de novo o mesmo. Se o mesmo já estiver carregado, este não é mais carregado. Ou seja, não fiz nenhuma alteração substancial que tenha feito seu código não funcionar mais.

Agora há pouco, inclusive, em mais um teste, desabilitei isso que havia feito e rodei mais uma vez o código. Não apresentou erro algum. Detalhe: estou trabalhando com o Excel 2007 e está tudo funcionando (pelo menos ao meu ver) perfeitamente.

Olá Morel !
O código que uso para descarregar de um form para outro é:

Private Sub UserForm_Terminate()

   With frmEntradas
        .txtClienteEnt.Value = frmEng.cbxCliente2.Value
        .txtReferenciaEnt.Value = frmEng.cbxReferencia2.Value
        .txtTempFornoEnt.Value = frmEng.txtTempoForno.Value
        .txtMinEnt.Value = frmEng.txtCargaMinima.Value
    End With

End Sub

Baixei o arquivo no meu PC e o funcionamento é outro, talvez, seja por que o meu Office esteja sem algumas DLL. Vou fazer o seguinte, vou tornar a tela de captura como tela de preenchimento e assim o usuário terá 2 formas de cadastrar. Uma manual e outra extraída de um banco.

agradeço muito a atenção, depois postarei o que vai dar !

Srs, Bom Dia!

Fiz outro form e deu erro 9 "subscrito fora de intervalo".

Por favor, solicito vossa ajuda!!!

Private Sub BTN_Cadastrar1_Click()

Dim NR As Long

    Sheets("ENTRADAS").Select
    Range("a1").End(xlDown).Select
    
      If cbxCliente2 = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
        cbxCliente2.SetFocus
        Exit Sub
    End If
    If cbxReferencia2.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
        cbxReferencia2.SetFocus
        Exit Sub
    End If
    If txtNfEnt1.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
        txtNfEnt1.SetFocus
        Exit Sub
    End If
    If txtDataEnt1.Text = "" Then
        MsgBox "PREENCHA A DATA DE ENTRADA", vbExclamation, "AVISO"
              Exit Sub
    End If
     If txtQdeEnt1.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
        txtQdeEnt1.SetFocus
        Exit Sub
    End If
    If txtLiqKgEnt1.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
        txtLiqKgEnt1.SetFocus
        Exit Sub
    End If
    If txtUniKgEnt1.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
       txtUniKgEnt1.SetFocus
        Exit Sub
    End If
    If txtPrazoEnt1.Text = "" Then
        MsgBox "PREENCHA A DATA DE ENTRADA", vbExclamation, "AVISO"
              Exit Sub
    End If
    If cbxLinhaEnt2.Text = "" Then
        MsgBox "ESCOLHA A LINHA", vbExclamation, "AVISO"
               Exit Sub
    End If
    If txtMinEnt1.Text = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
       txtMinEnt1.SetFocus
        Exit Sub
    End If
     If txtTempFornoEnt1 = "" Then
        MsgBox "PREENCHIMENTO OBRIGATÓRIO", vbExclamation, "AVISO"
       txtTempFornoEnt1.SetFocus
        Exit Sub
    End If
   

    NR = ActiveCell.Row
            
    Range("A65536").End(xlUp).Offset(1, 0).Select
    ActiveCell.Offset(0, 0).Value = LBL_NR.Caption
    ActiveCell.Offset(0, 1).Value = txtMinEnt1.Value
    ActiveCell.Offset(0, 2).Value = txtQdeEnt1.Value
    ActiveCell.Offset(0, 3).Value = CDbl(Me.txtLiqKgEnt1.Value)
    ActiveCell.Offset(0, 4).Value = CDbl(Me.txtUniKgEnt1.Value)
    ActiveCell.Offset(0, 5).Value = Format(txtDataEnt1.Value, "mm/dd/yy")
    ActiveCell.Offset(0, 6).Value = txtNfEnt1.Text
    ActiveCell.Offset(0, 7).Value = cbxCliente2.Text
    ActiveCell.Offset(0, 8).Value = cbxReferencia2.Text
    ActiveCell.Offset(0, 9).Value = Format(txtPrazoEnt1.Value, "mm/dd/yy")
    ActiveCell.Offset(0, 10).Value = txtTempFornoEnt1.Value
    ActiveCell.Offset(0, 11).Value = cbxLinhaEnt2.Text
     
    
    Columns("A:CR").AutoFit
        
    'FORMULAS PARA LIMPAR TODOS OS CAMPOS APOS UM CADASTRO
    
    txtMinEnt1 = ""
    txtQdeEnt1.Value = ""
    txtLiqKgEnt1.Value = ""
    txtUniKgEnt1.Value = ""
    txtDataEnt1.Text = ""
    
    cbxCliente2.Text = ""
    cbxReferencia2.Text = ""
    txtNfEnt1.Text = ""
    txtPrazoEnt1.Text = ""
    txtTempFornoEnt1.Value = ""
    cbxLinhaEnt2.Text = ""
    Me.LBL_NR = Sheets("ENTRADAS").Range("a65536").End(xlUp).Row - 1
    'LBL_NR
     cbxCliente2.SetFocus
  Call AutoMessage
  
End Sub

Private Sub cmdCalculetorEnt1_Click()
Call Calculadora
End Sub

Private Sub cmdDataEnt1_Click()
txtDataEnt1 = GetCalendário
End Sub

Private Sub cmdOrganizarEnt1_Click()
[B2:O5000].Sort Key1:=[F2], Order1:=xlAscending
End Sub

Private Sub cmdPrazoEnt1_Click()
txtPrazoEnt1 = GetCalendário
End Sub

Private Sub cmdSair1_Click()
Call Descarregar
Call TratError
Unload Me

End Sub

Private Sub cbxCliente2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub cmdSairEng1_Click()
Unload Me
End Sub

Private Sub txtDataEnt1_Change()
txtDataEnt1.Enabled = False
End Sub

Private Sub txtLiqKgEnt1_AfterUpdate()
 Me.txtLiqKgEnt1.Value = Format(Me.txtLiqKgEnt1.Value, "##,###0.00")
End Sub

Private Sub txtLiqKgEnt1_Change()
txtLiqKgEnt1.MaxLength = 9

End Sub
Private Sub txtLiqKgEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8 'Backspace (seta de apagar)
Case 48 To 57 'Números de 0 a 9
Case 44 'Vírgula
If InStr(txtLiqKgEnt1.Value, ",") Then 'Se o campo já tiver vírgula então ele não adiciona
KeyAscii = 0 'Não adiciona a vírgula caso ja tenha
Else
KeyAscii = 44 'Adiciona uma vírgula
End If
Case Else
KeyAscii = 0 'Não deixa nenhuma outra caractere ser escrito
End Select
End Sub

Private Sub txtMinEnt1_Change()
 txtMinEnt1.MaxLength = 6
End Sub

Private Sub txtMinEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8 'Backspace (seta de apagar)
Case 48 To 57 'Números de 0 a 9
Case 44 'Vírgula
If InStr(txtMinEnt1.Value, ",") Then 'Se o campo já tiver vírgula então ele não adiciona
KeyAscii = 0 'Não adiciona a vírgula caso ja tenha
Else
KeyAscii = 44 'Adiciona uma vírgula
End If
Case Else
KeyAscii = 0 'Não deixa nenhuma outra caractere ser escrito
End Select
End Sub

Private Sub txtNfEnt1_AfterUpdate()
 Me.txtNfEnt1.Value = Format(Me.txtNfEnt1.Value, "##,###")
End Sub

Private Sub txtNfEnt1_Change()
txtNfEnt1.MaxLength = 8
End Sub

Private Sub txtNfEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Permite apenas caracteres numéricos
If KeyAscii = vbKeyReturn Or KeyAscii = vbKeyBack Then Exit Sub
If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then
    KeyAscii = 0
End If
End Sub

Private Sub txtPrazoEnt1_Change()
 txtPrazoEnt1.Enabled = False
  End Sub

Private Sub txtQdeEnt1_AfterUpdate()
    Me.txtQdeEnt1.Value = Format(Me.txtQdeEnt1.Value, "##,###")
End Sub

Private Sub txtQdeEnt1_Change()
txtQdeEnt1.MaxLength = 6
 End Sub

Private Sub txtQdeEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Permite apenas caracteres numéricos
If KeyAscii = vbKeyReturn Or KeyAscii = vbKeyBack Then Exit Sub
If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then
    KeyAscii = 0
End If
End Sub

Private Sub cbxReferencia2_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub txtTempFornoEnt1_Change()
txtTempFornoEnt1.MaxLength = 4
End Sub

Private Sub txtTempFornoEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
'Permite apenas caracteres numéricos
If KeyAscii = vbKeyReturn Or KeyAscii = vbKeyBack Then Exit Sub
If KeyAscii < vbKey0 Or KeyAscii > vbKey9 Then
    KeyAscii = 0
End If
End Sub

Private Sub txtUniKgEnt1_AfterUpdate()
Me.txtUniKgEnt1.Value = Format(Me.txtUniKgEnt1.Value, "##,###0.0000")
End Sub

Private Sub txtUniKgEnt1_Change()
txtUniKgEnt1.MaxLength = 9
End Sub

Private Sub txtUniKgEnt1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Select Case KeyAscii
Case 8 'Backspace (seta de apagar)
Case 48 To 57 'Números de 0 a 9
Case 44 'Vírgula
If InStr(txtUniKgEnt1.Value, ",") Then 'Se o campo já tiver vírgula então ele não adiciona
KeyAscii = 0 'Não adiciona a vírgula caso ja tenha
Else
KeyAscii = 44 'Adiciona uma vírgula
End If
Case Else
KeyAscii = 0 'Não deixa nenhuma outra caractere ser escrito
End Select
End Sub

Private Sub UserForm_Initialize()
 Me.LBL_NR = Sheets("ENTRADAS").Range("a65536").End(xlUp).Row
Me.cbxLinhaEnt2.List = Application.WorksheetFunction.Transpose(Plan6.Range("B2:B6"))
 Call CarregaClientes
End Sub

Private Sub UserForm_Layout()
         'Proximidade  top/left
    Me.Top = Application.Top + 110
    Me.Left = Application.Left + 25
End Sub

Private Sub Preenche()
Dim UltimaLinha As Integer, y As Long, i As Long, x As Object

cbxReferencia2.Clear
If cbxCliente2.ListIndex > -1 Then

        Sheets(cbxCliente2.List(cbxCliente2.ListIndex, 0)).Select
    Else
           MsgBox "Dados Transferidos"
    End If
'plan1 0
'plan2 1
'plan3 2
'plan4 3

For Each x In Worksheets
    UltimaLinha = Cells(Cells.Rows.Count, "A").End(xlUp).Row
    For y = 1 To UltimaLinha - 1
        
                 cbxReferencia2.AddItem Cells(y + 1, 1).Value
           
               Dim Rng As Range
   Dim Dn As Range
   Dim Dic As Object
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
    Set Dic = CreateObject("scripting.dictionary")
        Dic.CompareMode = vbTextCompare
For Each Dn In Rng
  If Not Dn = vbNullString Then Dic(Dn.Value) = Empty
Next
With Me.cbxReferencia2
    .RowSource = ""
    .List = Dic.Keys
    .ListIndex = 0
End With
    Next y
Next
Call SemDuplicidade
End Sub

Private Sub cbxCliente2_Change()
Call Preenche
End Sub

Private Sub cbxReferencia2_Change()
txtMinEnt1.Value = Cells(cbxReferencia2.ListIndex + 2, 5).Value
txtTempFornoEnt1.Value = Cells(cbxReferencia2.ListIndex + 2, 42).Value
End Sub

Private Sub cmdVoltarEng_Click()
'Call Descarregar
'Call TratError

 'Workbooks("BD Eng.xls").Close savechanges:=False 'ou True
'Unload Me
'frmEntradas.Show
End Sub


 Private Sub CarregaClientes()

       With Me.cbxCliente2
    Set SourceWB = Workbooks.Open("C:UsersLaerteDesktopBD Eng.xls", _
            False, True)

             For Each x In Worksheets
       cbxCliente2.AddItem x.name
    Next
    End With
              
   
End Sub

Private Sub GetArquivo()

    Dim sArquivo
    Dim sEspecificação As String
    Dim sTítulo As String
    
    sEspecificação = "Arquivos de Excel (*.xls*),*.xls*"
    sTítulo = "Selecione um arquivo do Excel:"
    
    sArquivo = CStr(Application.GetOpenFilename(sEspecificação, , sTítulo, , False))
    
    If sArquivo <> CStr(False) Then
        Debug.Print sArquivo
    Else
        'Nenhum arquivo foi selecionado
    End If

End Sub

Olá pessoal!

somente para fechar o tópico. O erro era não ter declarado as variáveis, veja:

Private Sub CarregaClientes()
       Dim WB As Workbook
Dim SourceWB As Workbook
Dim WS As Worksheet
       With Me.cbxCliente2
    Set SourceWB = Workbooks.Open("C:UsersLaerteDesktopBD Eng.xls", _
            False, True)

             For Each x In Worksheets
       cbxCliente2.AddItem x.name
    Next

Olá pessoal!

somente para fechar o tópico. O erro era não ter declarado as variáveis, veja:

Private Sub CarregaClientes()
    [color=#FF0000]   Dim WB As Workbook
[color=#BF0000]Dim SourceWB As Workboo[/color]k
[color=#FF0000]Dim X As Worksheet[/colo[/color]r]
       With Me.cbxCliente2
    Set SourceWB = Workbooks.Open("C:UsersLaerteDesktopBD Eng.xls", _
            False, True)

             For Each x In Worksheets
       cbxCliente2.AddItem x.name
    Next

Caso seja necessário reabrir o tópico, o autor poderá enviar uma MP para um dos moderadores solicitando o desbloqueio.