rolano

Sub Consulta_Registros() Dim conexion As ADODB.Connection Dim recordset As ADODB.recordset Dim Consulta As String Dim MiBase As String Set conexion = New ADODB.Connection MiBase = "\DBClientes.accdb" conexion.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & "Data Source=" & Application.ThisWorkbook.Path & Application.PathSeparator & MiBase Consulta = "SELECT * FROM TClientes " Set recordset = New ADODB.recordset recordset.Open Consulta, conexion, adOpenKeySet, adLockOptimistic, adCmdTableDirect Dim total_reg As Integer UserForm1.TextBox1.Value = recordset.RecordCount total_reg = 0 Set recordset = Nothing Set conexion = Nothing End Sub Hola a todos, mangelperu, así también puede funciona. Saludos, César

Hola Milton, esta mal escrito celda.seletc debe de decir celda.select. Tu formato de celda ( rango C5:C10) esta como texto, cambio a general. Saludos,

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$7" Then If UCase(Target.Value) = "JUAN" Then Macro1 ElseIf UCase(Target.Value) = "MARIA" Then Macro2 End If End If If Target.Address = "$J$9" Then If UCase(Target.Value) = "HOMBRE" Then Macro11 ElseIf UCase(Target.Value) = "MUJER" Then Macro12 End If End If End Sub Sub Macro1() Range("J21").Value = "Debo decir Juan" ActiveSheet.Range("$J$9").Calculate Range("A1").Select End Sub Sub Macro2() Range("J21").Value = "Debo decir Maria" Range("A1").Select End Sub Sub Macro11() Range("J23").Value = "Esto es porque has dicho Juan" Range("A1").Select End Sub Sub Macro12() Range("J23").Value = "Esto es porque has dicho Maria" Range("A1").Select End Sub

Texto Prueba 1.xlsm

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$7" Then If UCase(Target.Value) = "JUAN" Then Macro1 ElseIf UCase(Target.Value) = "MARIA" Then Macro2 End If End If End Sub Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$7" Then If UCase(Target.Value) = "JUAN" Then Macro1 ElseIf UCase(Target.Value) = "MARIA" Then Macro2 End If End If End Sub Sub Macro1() Genero = InputBox(Genero, "GENERO") Range("J9").Value = Genero Range("J21").Value = "Debo decir Juan" ActiveSheet.Range("$J$9").Calculate If Range("J9").Value = "HOMBRE" Then Macro11 ElseIf Range("J9").Value = "MUJER" Then Macro12 End If Range("A1").Select End Sub Sub Macro2() Genero = InputBox(Genero, "GENERO") Range("J9").Value = Genero Range("J21").Value = "Debo decir Maria" If Range("J9").Value = "HOMBRE" Then Macro11 ElseIf Range("J9").Value = "MUJER" Then Macro12 End If Range("A1").Select End Sub Sub Macro11() Range("J23").Value = "Esto es porque has dicho Juan" Range("A1").Select End Sub Sub Macro12() Range("J23").Value = "Esto es porque has dicho Maria" Range("A1").Select End Sub Texto Prueba 1.xlsm

Hola, sube un archivo de muestra. Recuerda que el código tiene que estar en la hoja que estas trabajando

Dim C As Range, mPath$ Image1.Picture = LoadPicture("") Set C = Hoja8.Range("a1").CurrentRegion.Columns(2).Find(ComboBox1, , LookIn:=xlValues, LookAt:=xlPart)'<--Cambia a XlPart' If C Is Nothing Then Exit Sub Worksheets("inventario").Visible = True Worksheets("inventario").Select C.Select mPath = ThisWorkbook.path & "\imagenes\" mPath = mPath & Dir(mPath & Format(C.Offset(, -1), "FEC-" & "0000") & ".*") if mPath<>"" then Image1.Picture = LoadPicture(mPath) Else Image1.Picture = LoadPicture(ThisWorkbook.path & "\imagenes\FEC-000000.JPG") 'MsgBox "No se encuentra la imagen" Exit Sub End If

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Address = "$J$7" Then If UCase(Target.Value) = "JUAN" Then Macro1 ElseIf UCase(Target.Value) = "MARIA" Then Macro2 End If End If End Sub Sub Macro1() Range("J9").Value = "HOMBRE" Range("J21").Value = "Debo decir Juan" ActiveSheet.Range("$J$9").Calculate If Range("J9").Value = "HOMBRE" Then Macro11 ElseIf Range("J9").Value = "MUJER" Then Macro12 End If Range("A1").Select End Sub Sub Macro2() Range("J9").Value = "MUJER" Range("J21").Value = "Debo decir Maria" If Range("J9").Value = "HOMBRE" Then Macro11 ElseIf Range("J9").Value = "MUJER" Then Macro12 End If Range("A1").Select End Sub Sub Macro11() Range("J23").Value = "Esto es porque has dicho Juan" Range("A1").Select End Sub Sub Macro12() Range("J23").Value = "Esto es porque has dicho Maria" Range("A1").Select End Sub Hola Juan, revisa el código

Private Sub CommandButton2_Click() On Error Resume Next Dim b As Object Dim a As Object Dim dato0 Dim dato1 Dim dato2 Dim fila As Integer Dim i As Integer Dim uf As String Dim uc As String Dim wc As String Dim strg As String Set b = Sheets("Resguardo") uf = b.Range("A" & Rows.Count).End(xlUp).Row dato1 = VBA.CDate(TextBox2) dato2 = VBA.CDate(TextBox3) If dato2 = "" Or dato1 = "" Then MsgBox ("Debe ingresar datos para consulta entre rango de fechas"), vbCritical, "AVISO" Exit Sub End If If dato2 < dato1 Then MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO" Exit Sub End If b.AutoFilterMode = False Me.ListBox1 = "Clear" Me.ListBox1.RowSource = "Clear" 'Elimina hoja y crea hoja dando el mismo nombre que la eliminada Sheets("Temporal").Delete ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = "Temporal" Set a = Sheets("Temporal") b.Range("A1:I1").Copy Destination:=a.Range("A1") fila = 2 If dato2 < dato1 Then MsgBox ("La fecha final no puede ser mayor a la fecha inicial"), vbCritical, "AVISO" Exit Sub End If For i = 2 To uf strg = b.Cells(i, 7).Value dato0 = VBA.CDate(b.Cells(i, 6).Value) If VBA.UCase(strg) Like VBA.UCase(TextBox1.Value) & "*" And dato0 >= dato1 And dato0 <= dato2 Then a.Cells(fila, 1) = b.Cells(i, 1) a.Cells(fila, 2) = b.Cells(i, 2) a.Cells(fila, 3) = b.Cells(i, 3) a.Cells(fila, 4) = b.Cells(i, 4) a.Cells(fila, 5) = b.Cells(i, 5) a.Cells(fila, 6) = VBA.Format(b.Cells(i, 6), "mm/dd/yyyy;@") a.Cells(fila, 7) = b.Cells(i, 7) a.Cells(fila, 8) = b.Cells(i, 8) a.Cells(fila, 9) = b.Cells(i, 9) fila = fila + 1 End If Next i a.Range("I").NumberFormat = VBA.Format("dd/mm/yyyy") With Sheets("Temporal") ListBox1.List = .Range("a2", .[i2].End(xlDown)).Value End With TextBox1.SetFocus End Sub Private Sub CommandButton3_Click() Dim sino As String sino = MsgBox("Estas seguro de cerrar la Busqueda de Resguardo, antes debes guardar?", vbYesNo + vbQuestion, "CONFIRMA") If sino <> vbYes Then Exit Sub Application.ScreenUpdating = False Application.Visible = False 'Application.Windows(ThisWorkbook.Name).Visible = False Worksheets("Temporal").Select Worksheets("Temporal").Delete Unload Me 'Menu.Show Application.ScreenUpdating = True End Sub Private Sub CommandButton4_Click() Dim h1 As Object Dim C As Integer Dim f As Integer Set h1 = Sheets("ReporteResguardo") h1.Rows("2:" & Rows.Count).ClearContents C = ListBox1.ColumnCount f = ListBox1.ListCount h1.Range(h1.Cells(2, "A"), h1.Cells(f + 1, C)) = ListBox1.List MsgBox ("Los datos se copiaron con éxito"), vbInformation, "AVISO" CommandButton3.Visible = True End Sub Private Sub CommandButton5_Click() Application.Help ThisWorkbook.Path & "\Ayuda.chm" End Sub Private Sub CommandButton6_Click() EliminarFilas2.Show End Sub Private Sub DTPicker1_Change() TextBox2 = DTPicker1 End Sub Private Sub DTPicker2_Change() TextBox3 = DTPicker2 End Sub Private Sub ListBox1_Click() CommandButton6.Visible = True End Sub Private Sub TextBox1_Change() Application.DisplayAlerts = False Application.ScreenUpdating = False On Error Resume Next Dim b As Object Dim a As Object Dim dato0 Dim dato1 Dim dato2 Dim fila As Integer Dim i As Integer Dim uf As String Dim uc As String Dim wc As String Dim strg As String Set b = Sheets("Resguardo") uf = b.Range("A" & Rows.Count).End(xlUp).Row If VBA.Trim(TextBox1.Value) = "" Then With Sheets("Resguardo") ListBox1.List = .Range("a2", .[i2].End(xlDown)).Value End With Exit Sub End If b.AutoFilterMode = False Me.ListBox1 = "Clear" Me.ListBox1.RowSource = "Clear" dato1 = VBA.CDate(TextBox2) dato2 = VBA.CDate(TextBox3) 'Elimina hoja y crea hoja dando el mismo nombre que la eliminada Sheets("Temporal").Delete ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count) ActiveSheet.Name = "Temporal" Set a = Sheets("Temporal") b.Range("A1:I1").Copy Destination:=a.Range("A1") fila = 2 For i = 2 To uf strg = b.Cells(i, 7).Value If VBA.UCase(strg) Like VBA.UCase(TextBox1.Value) & "*" Then a.Cells(fila, 1) = b.Cells(i, 1) a.Cells(fila, 2) = b.Cells(i, 2) a.Cells(fila, 3) = b.Cells(i, 3) a.Cells(fila, 4) = b.Cells(i, 4) a.Cells(fila, 5) = b.Cells(i, 5) a.Cells(fila, 6) = VBA.Format(b.Cells(i, 6), "mm/dd/yyyy;@") a.Cells(fila, 7) = b.Cells(i, 7) a.Cells(fila, 8) = b.Cells(i, 8) a.Cells(fila, 9) = b.Cells(i, 9) fila = fila + 1 End If Next i a.Range("I").NumberFormat = VBA.Format("dd/mm/yyyy") With Sheets("Temporal") ListBox1.List = .Range("a2", .[i2].End(xlDown)).Value End With End Sub Private Sub UserForm_Initialize() 'Dim b As Object 'Dim uf As Integer 'Dim uc, wc As String ' Application.DisplayAlerts = False Application.ScreenUpdating = False With Sheets("Resguardo") ListBox1.List = .Range("a2", .[i2].End(xlDown)).Value End With Application.DisplayAlerts = True Application.ScreenUpdating = True 'Al iniciar el formulario asignamos un mensaje tooltip al botón, 'así como un ícono personalizado para ser mostrado en over Me.CommandButton5.ControlTipText = "Mostrar la ayuda de este formulario." Me.CommandButton5.MousePointer = fmMousePointerHelp CommandButton3.Visible = False CommandButton6.Visible = False End Sub ' 'Evita Cerrar La Ventana Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) If CloseMode = 0 Then MsgBox "Use el botón Cerrar del formulario", vbInformation, " Botón No Disponible " Cancel = 1 CloseMode = 1 End If End Sub Private Sub UserForm_Activate() Application.ScreenUpdating = False Application.Visible = False TextBox1 = Empty TextBox1.SetFocus Application.ScreenUpdating = True ' DTPicker1.Value = VBA.Date ' TextBox2.Value = DTPicker1.Value ' DTPicker2.Value = VBA.Date ' TextBox3.Value = DTPicker2.Value CommandButton3.Visible = False CommandButton6.Visible = False End Sub Sub eliminarProducto() 'Borrar del ListBox y de las hojas On Error Resume Next Dim sino As String sino = MsgBox("Estás seguro de Eliminar el Articulo seleccionado?", vbYesNo + vbQuestion, "CONFIRMA") If sino <> vbYes Then Exit Sub Dim fila As Integer Dim Final As Integer Dim Cantidad As Integer ''''AQUI REGISTRO EL CORRELATIVO FINAL PROCESADO Application.ScreenUpdating = False Dim NombreHoja As String NombreHoja = "Inventario" 'Buscamos la última fila 'EN EL SIGUIENTE ME ESTOY REFIRIENDO A LA HOJA SEGUN EL SECTOR fila = 2 Do While ThisWorkbook.Sheets(NombreHoja).Cells(fila, 1) <> "" fila = fila + 1 Loop Final = fila 'CON ESTE CODIGO ESTARE RESTANDO "1" AL FOLIO EN CASO SE REGRESE A LA VENTANA ANTERIOR For fila = 2 To Final If ThisWorkbook.Sheets(NombreHoja).Cells(fila, 1) = ListBox1.List(ListBox1.ListIndex, 0) Then 'CORRESPONDE A LA COLUMNA "A" ThisWorkbook.Sheets(NombreHoja).Cells(fila, 8) = ThisWorkbook.Sheets(NombreHoja).Cells(fila, 7) - Val(ListBox1.List(ListBox1.ListIndex, 5)) Exit For End If Next '///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////// Dim row_LB& With Busqueda_Resguardo.ListBox1 row_LB = .ListIndex If row_LB = -1 Then Exit Sub Hoja3.Activate ' Se busca por numero de la Fact en el listbox1 If Hoja3.Columns("A").Find(What:=.List(row_LB, 0), LookAt:=xlWhole).Activate Then CeldaFact = ActiveCell.Text If CeldaFact = .List(row_LB, 0) Then Cells(ActiveCell.Row, "A").EntireRow.Delete End If End If Sheets("Temporal").Activate ' Se busca por numero de la Fact en el listbox1 If Sheets("Temporal").Columns("A").Find(What:=.List(row_LB, 0), LookAt:=xlWhole).Activate Then CeldaFact = ActiveCell.Text If CeldaFact = .List(row_LB, 0) Then Cells(ActiveCell.Row, "A").EntireRow.Delete End If End If Hoja10.Activate ' Se busca por numero de la Fact en el listbox1 If Hoja10.Columns("A").Find(What:=.List(row_LB, 0), LookAt:=xlWhole).Activate Then CeldaFact = ActiveCell.Text If CeldaFact = .List(row_LB, 0) Then Cells(ActiveCell.Row, "A").EntireRow.Delete End If End If Hoja5.Activate ' Se busca por numero de la Fact en el listbox1 If Hoja5.Columns("A").Find(What:=.List(row_LB, 0), LookAt:=xlWhole).Activate Then CeldaFact = ActiveCell.Text If CeldaFact = .List(row_LB, 0) Then Cells(ActiveCell.Row, "A").EntireRow.Delete End If End If .RemoveItem row_LB .ListIndex = -1 End With 'With Sheets("Salidas") ' .Range("a2:n2").Offset(row_LB).Delete xlShiftUp 'End With ' 'With Sheets("Temporal") ' .Range("a2:n2").Offset(row_LB).Delete xlShiftUp 'End With ' 'With Sheets("Resguardo") ' .Range("a2:i2").Offset(row_LB).Delete xlShiftUp 'End With ' 'With Sheets("Stock") ' .Range("a2:n2").Offset(row_LB).Delete xlShiftUp 'End With ' Application.ScreenUpdating = True MsgBox "Selección eliminada" End Sub Hola Alfonso, pega estos codigos en el userform Busqueda_Resguardo. Recuerda que el numero de factura debe ser igual y única en todas las hojas. Saludos, César

Hola Ibrahim, revisa en: Private Sub UserForm_Initialize() o Private Sub UserForm_Activate(), ahi debe haber un código que se ejecuta en el textbox4, para realizar la numeración como describes. O sube tu archivo de ejemplo.

Hola José, al principio llenas el listbox con datos de la hoja inventario, luego llenas el listbox con la hoja temporal, el index del combobox cambia, y no puedes borrar datos de otra hoja con index que no le corresponde. Analiza bien tu programación. Saludos,

Hola Ibrahim, si tu código esta algo así como Format(text, "0000") , cambio por Format(text, "###0")

Private Sub ComboBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) CommandButton6.Visible = True End Sub Hola José, si lo colocas en el combobox al presionar doble click

Me.cboFamilia.RowSource = Names("Familia").RefersTo Me.cmbVentas.RowSource = Names("yUOM").RefersTo Me.cmbInventario.RowSource = Names("yUOM").RefersTo Me.cmbCompras.RowSource = Names("yUOM").RefersTo Hola José, los combobox llenalos según el código adjunto

Gracias estimado Abraham, voy hacer lo que indicas, de loguearme con internet explorer.