Jump to content

rolano

Members
  • Content Count

    1,200
  • Joined

  • Last visited

  • Days Won

    10
  • Country

    Peru

Everything posted by rolano

  1. Hola Marcosab, revisa el adjunto. Puedes explicar un poco mas con ejemplo. Datos.ro.rar
  2. Hola Maurizio, revisa el adjunto haber si lo he atinado. Crea_Password.rar
  3. Hola Antoni un gusto saludarte, allí debería ser hoja3 y no hoja1, ahora lo que hice es poner manualmente el numero de serie disco C en la hoja3 celda Range("B100000").
  4. Hola a todos, tu archivo no abre porque tienes que tienes que colocar el numero de serie de tu disco C en la hojas. CONTROL RECONOCIMIENTO DE COMPUTADOR.xlsm
  5. Sub Apri_Tabella() On Error Resume Next DoCmd.Close DoCmd.OpenTable "Tabella_Database", acViewNormal End Sub Hola, revisa este código.
  6. Hola, revisa el archivo adjunto, ingrese con el usuario Maury. Crea_Password.accdb
  7. Hola, pueda que te sirva takeout google. https://www.youtube.com/watch?v=crMZi2Lk5WI
  8. Public Declare PtrSafe Function SetTimer Lib "user32" ( _ ByVal hWnd As Long, _ ByVal nIDEvent As Long, _ ByVal uElapse As Long, _ ByVal lpTimerFunc As LongPtr) As Long 'LongPtr cambialo por Long Hola a todos, es esta parte cambia LongPtr por Long, a mi me funciona as´s.
  9. Option Explicit Option Base 1 'EXPORTAR DATOS Sub Botón3_Haga_clic_en_R() 'On Error GoTo etiqueta Application.ScreenUpdating = False Dim vehiculo As String, fila As Long, colum As Long Dim NCarga As String, FechaSalida As String, FechaLlegada As String, PoblaciónOrigen As String, PoblaciónDestino As String Dim KmsNac As Integer, KmsInt As Integer, Precioventa As Double, PrecioKmsNac As Double, PrecioKmsInt As Double Dim filadest As Integer, columdest As Integer Dim pasardatos As Long, ultimafila As Long Dim Hoja As String Dim listacamioneskm() As String, i As Integer, matriz As Range Dim CantFila As Long Dim HojaEstado As Object 'funciona Worksheets("listacamioneskm").Select CantFila = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Range("A1:A" & CantFila).Select 'funciona i = 1 For Each matriz In Selection ReDim Preserve listacamioneskm(CantFila) listacamioneskm(i) = matriz.Value i = i + 1 Next matriz fila = 2 colum = 0 'filadest = 2 columdest = 1 Do Worksheets("GS").Select 'hoja = Cells(fila, colum + 1).Value 'fila 2, columna 1 vehiculo = Cells(fila, 1).Value If vehiculo = "" Then Exit Sub If UBound(Filter(listacamioneskm, vehiculo)) >= 0 Then vehiculo = Cells(fila, 1).Value NCarga = Cells(fila, 2).Value FechaSalida = Cells(fila, 3).Value FechaLlegada = Cells(fila, 4).Value PoblaciónOrigen = Cells(fila, 5).Value PoblaciónDestino = Cells(fila, 6).Value KmsNac = Cells(fila, 7).Value KmsInt = Cells(fila, 8).Value Precioventa = Cells(fila, 9).Value PrecioKmsNac = Cells(fila, 10).Value PrecioKmsInt = Cells(fila, 11).Value 'enviamos datos 'hay que enviar antes de que salte de fila Worksheets(vehiculo).Select filadest = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Sheets(vehiculo).Cells(filadest + 1, columdest).Value = vehiculo Sheets(vehiculo).Cells(filadest + 1, columdest + 1).Value = NCarga Sheets(vehiculo).Cells(filadest + 1, columdest + 2).Value = FechaSalida Sheets(vehiculo).Cells(filadest + 1, columdest + 3).Value = FechaLlegada Sheets(vehiculo).Cells(filadest + 1, columdest + 4).Value = PoblaciónOrigen Sheets(vehiculo).Cells(filadest + 1, columdest + 5).Value = PoblaciónDestino Sheets(vehiculo).Cells(filadest + 1, columdest + 6).Value = KmsNac Sheets(vehiculo).Cells(filadest + 1, columdest + 7).Value = KmsInt Sheets(vehiculo).Cells(filadest + 1, columdest + 8).Value = PrecioKmsNac Sheets(vehiculo).Cells(filadest + 1, columdest + 9).Value = PrecioKmsInt Sheets(vehiculo).Cells(filadest + 1, columdest + 10).Value = Precioventa End If fila = fila + 1 Loop While vehiculo <> "" Application.ScreenUpdating = True End Sub Hola a todos, es tu misma rutina (Módulo3), con algunas modificaciones,. revisalo. Si tienes otra pregunta abre un nuevo tema para que tengas mas oportunidad de ayuda. MACROMod.xlsm
  10. Hola, como relacionas tu tabla Hoja(GS") y Hoja("listacamioneskm") o Hoja("listacamioneskms"). En tu Hoja("GS") deberías insertar en la columna "A" Vehículo y sus respectivos números. Porque para extraer la informacion de la Hoja(GS") a las Hoja("1111") y sucesivo, se necesita que en la Hoja(GS") tenga una relación con las otras hojas. Después Option Explicit coloca Option Base 1
  11. 'Copia los datos de la celda list box a = ListBox1.ListCount ListBox1.AddItem ListBox1.List(a, 0) = Sheets("bd").Cells(fila, 2) ListBox1.List(a, 1) = Sheets("bd").Cells(fila, 3) ListBox1.List(a, 2) = Sheets("bd").Cells(fila, 4) ListBox1.List(a, 3) = Sheets("bd").Cells(fila, 7) ListBox1.List(a, 4) = Sheets("bd").Cells(fila, 8) ListBox1.List(a, 5) = Sheets("bd").Cells(fila, 9) ListBox1.List(a, 6) = Format(Sheets("bd").Cells(fila, 10), "$###,##0") 'Cambiar ListBox1.List(a, 7) = Format(Sheets("bd").Cells(fila, 13), "$###,##0") 'Cambiar ListBox1.List(a, 8) = Format(Sheets("bd").Cells(fila, 14), "$###,##0") 'Cambiar ListBox1.List(a, 9) = Format(Sheets("bd").Cells(fila, 15), "$###,##0") 'Cambiar Hola, cambia en el fila 10, 13, 14 y 15 (Format(Sheets("bd").Cells(fila, 10), "$###,##0") 'Cambiar)
  12. option base 1 for x = 1 to 23 If vehiculo = listacalidad(x) then 'codigo end if Hola, prueba con este código.
  13. Sub FC() Range("C3").Copy Range(A2:A6).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False 'copia el formato condicional de la celda C3 a las celdas A2:A6 End Sub Sub FormatoCondicional() With Range("$A$1:$A$5").FormatConditions .Delete .Add(xlExpression, , "Formula1") .Item(1).Interior.Color = Range("C3").Interior.Color .Item(1).Font.Bold = True .Item(1).Font.ColorIndex = 2 End With End Sub Hola, prueba con estas modificaciones.
  14. Hola, se mas explicito, donde no te funcionó. Tienes que ver que el comentario este en la celda del código y el texbox.
  15. n = Application.WorksheetFunction.Match(Me.cbo_Categoria.Value, sh.Range("1:1"), 0) If n = "" Then MsgBox " Sin Dato " else Me.cbo_Tipo.Clear For i = 2 To Application.WorksheetFunction.CountA(sh.Cells(1, n).EntireColumn) Me.cbo_Tipo.AddItem sh.Cells(i, n).Value Next i en If Hola, revisa el código.
  16. TextBox1 = Range("A7").Comment.Text Hola prueba así.
  17. Hola, donde te da el error. Recuerda que en el archivo origen donde esta la macro tienes que tener una hoja con nombre "analysis" y en el archivo destino una hoja con nombre "sheet1".
  18. Sub AleaIactaEst() Dim cuant As Integer: cuant = Range("B1") Dim aleat As Integer Dim r As Range: Set r = Range("F2:F15") Dim q, i As Integer Worksheets(1).Range("F2:H15").ClearContents '-------------------------------------------------------------------------------------- 'Aleatorios '-------------------------------------------------------------------------------------- q = 0 Do aleat = Application.WorksheetFunction.RandBetween(Range("B2"), Range("B3")) q = q + 1: If q > cuant Then Exit Do r(q, 1) = aleat If q > 1 Then For i = 1 To q - 1 If r(i, 1) = aleat Then r(q, 1) = "" q = q - 1 Exit For End If Next End If Loop '-------------------------------------------------------------------------------------- Range("F2:F15").Sort Key1:=Range("F2:F15"), Order1:=xlAscending Cells(17, 6) = Application.WorksheetFunction.Sum(ActiveSheet.Range("F2:F15")) '-------------------------------------------------------------------------------------- Range("F18").Formula = "=MOD(SUM(F2:F15)-1,9)+1" Range("F18").Value = Range("F18").Value 'Boorar esta linea si quieres que se vea la formula. Exit Sub End Sub Hola, prueba con el código añadido.
  19. ActiveWorkbook.Sheets(1).ChartObjects("Grafico_1").Select Hola, prueba así
  20. 'Option Explicit Option Base 1 Public Sub VENTAS_SECCION_MES() Dim sql As String, SheetName As String Dim AÑO, CENTRO, SECCION, MES As String Dim strConectar As String Sheets("Ventas").Select Range("C5").Select Application.ScreenUpdating = False AÑO = Range("C2").Value CENTRO = Range("A3").Value MES = Range("C3").Value SECCION = ActiveCell.Offset(0, -2).Value 'Application.Cursor = xlWait Dim wb As Workbook, ws As Worksheet 'Venta de un año, un mes, una tienda y una sección sql = "SUM[TOT_VENTAS]) AS TOTAL_VENTAS FROM PRESUPUESTO_VENTAS WHERE,[ANYO] = 'AÑO'), AND ([COD_CC] = 'CENTRO'), AND ([SECCION] = SheetName = "Ventas" Set wb = ActiveWorkbook Set ws = wb.ActiveSheet ws.Name = SheetName ' Poner los datos particulares de la conexión Dim Con As New ADODB.Connection Con.Open "provider=IBMDA400;data source=172.16.1.1;Default Collection=-----;USER ID=---;PASSWORD=------;" DownloadQuery Con, sql, SheetName Con.Close Set Con = Nothing Set wb = Nothing Set ws = Nothing Application.Cursor = xlDefault Application.ScreenUpdating = False End Sub Private Sub DownloadQuery(Con As ADODB.Connection, sql As String, SheetName As String) Dim Cmd As ADODB.Command Dim Rs As ADODB.Recordset Set Cmd = New ADODB.Command Set Cmd.ActiveConnection = Con Cmd.CommandText = sql Dim ws As Worksheet, fld As ADODB.Field Set ws = Worksheets(SheetName) 'Set Rs = Cmd.Execute() Set Rs = New ADODB.Recordset Rs.Open "PRESUPUESTO_VENTAS", Con, adOpenKeyset, adLockOptimistic, adCmdTableDirect ' Me trae el dato de la Consulta SQL 'ActiveCell.CopyFromRecordset Rs 'LimpiaRango ws.Range("C5:C18").ClearContents Rs.MoveFirst Do While Not Rs.EOF dFecha = Rs.Fields(12) 'Año wsFecha = Val(ws.Range("C2")) dCentro = Rs.Fields(2) 'Centro wsCentro = Val(ws.Range("A3")) dSeccion = Rs.Fields(5) 'Seccion dMes = Rs.Fields(15) 'Mes wsMes = Val(Range("C3")) For I = 5 To 18 wsSeccion = Val(Range("A" & I)) If dSeccion = wsSeccion And dMes = wsMes Then If dFecha = wsFecha And dCentro = wsCentro Then If Val(ws.Range("A" & I)) = Rs.Fields(5) Then Valor = Val(ws.Range("C" & I)) + Rs.Fields(9) ws.Range("C" & I) = Valor End If End If End If Next I Rs.MoveNext Loop Set fld = Nothing Set Rs = Nothing End Sub Hola, trata de declarar las variables.
  21. 'Option Explicit Option Base 1 Public Sub VENTAS_SECCION_MES() Dim SheetName As String Dim strConectar As String Dim ws As Worksheet Dim wb As Workbook Dim Cmd As ADODB.Command Dim Rs As ADODB.Recordset Application.ScreenUpdating = False Sheets("Ventas").Select 'Range("C5").Select Application.Cursor = xlWait SheetName = "Ventas" Set wb = ActiveWorkbook Set ws = wb.ActiveSheet ws.Name = SheetName ' Poner los datos particulares de la conexión Dim Con As New ADODB.Connection Con.Open "provider=IBMDA400;data source=172.16.1.1;Default Collection=-----;USER ID=---;PASSWORD=------;" ' Dim Con As New ADODB.Connection ' strConectar = ThisWorkbook.Path & "\BDVentas.mdb" ' With Con ' .ConnectionString = _ ' "Provider=Microsoft.ACE.OLEDB.12.0" ' .Open "Provider=Microsoft.Jet.OLEDB.4.0; " & _ ' "Data Source=" & strConectar & ";" & _ ' "Jet OLEDB:Database Password=Ventas" ' End With Set ws = Worksheets(SheetName) Set Rs = New ADODB.Recordset Rs.Open "PRESUPUESTO_VENTAS", Con, adOpenKeyset, adLockOptimistic, adCmdTableDirect ' Me trae el dato de la Consulta SQL 'ActiveCell.CopyFromRecordset Rs 'LimpiaRango ws.Range("C5:C18").ClearContents Rs.MoveFirst Do While Not Rs.EOF dFecha = Rs.Fields(12) 'Año wsFecha = Val(ws.Range("C2")) dCentro = Rs.Fields(2) 'Centro wsCentro = Val(ws.Range("A3")) dSeccion = Rs.Fields(5) 'Seccion dMes = Rs.Fields(15) 'Mes wsMes = Val(Range("C3")) For I = 5 To 18 wsSeccion = Val(Range("A" & I)) If dSeccion = wsSeccion And dMes = wsMes Then If dFecha = wsFecha And dCentro = wsCentro Then If Val(ws.Range("A" & I)) = Rs.Fields(5) Then Valor = Val(ws.Range("C" & I)) + Rs.Fields(9) ws.Range("C" & I) = Valor End If End If End If Next I Rs.MoveNext Loop Con.Close Set Rs = Nothing Set Con = Nothing Set wb = Nothing Set ws = Nothing Application.Cursor = xlDefault Application.ScreenUpdating = True End Sub Hola a todos, revisa este código adjunto, lo he corrido en un archivo de access. Tienes que ver como esta su base de datos los campos afectados deben ser números.
  22. Hola Cecilio, adjunto el código para que lo reescribas en tu proyecto.
  23. Sub MAC() Application.ScreenUpdating = False Set H1 = Sheets("Hoja1") Set H2 = Sheets("Hoja3") ultimfb = H2.Range("B" & Rows.Count).End(xlUp).Row + 1 H2.Range("B4" & ": AV" & ultimfb).Clear H1.Activate Range("A9").Select Do While ActiveCell <> "FIN" If Len(ActiveCell.Value) = 6 Then ultimfd = H2.Range("B" & Rows.Count).End(xlUp).Row + 1 ActiveCell.Offset(0, 0).Copy H2.Range("B" & ultimfd).PasteSpecial xlValues End If ActiveCell.Offset(1, 0).Select Loop H2.Activate 'ultimf = Range("AV" & Rows.Count).End(xlUp).Row For i = 4 To H2.Range("b" & Rows.Count).End(xlUp).Row Set b = H1.Range("A:A").Find(H2.Cells(i, "b"), lookat:=xlPart) If Not b Is Nothing Then H1.Range("B" & b.Row).Copy H2.Cells(i, "C").PasteSpecial xlValues If Not b Is Nothing And H1.Range("C" & b.Row) > 0 Then H1.Range("C" & b.Row).Copy H2.Cells(i, "D").PasteSpecial xlValues If Not b Is Nothing And H1.Range("D" & b.Row) > 0 Then H1.Range("D" & b.Row).Copy H2.Cells(i, "E").PasteSpecial xlValues If Not b Is Nothing And H1.Range("E" & b.Row) > 0 Then H1.Range("E" & b.Row).Copy H2.Cells(i, "F").PasteSpecial xlValues If Not b Is Nothing And H1.Range("F" & b.Row) >= 0 Then H1.Range("F" & b.Row).Copy H2.Cells(i, "G").PasteSpecial xlValues If Not b Is Nothing And H1.Range("G" & b.Row) >= 0 Then H1.Range("G" & b.Row).Copy H2.Cells(i, "H").PasteSpecial xlValues End If End If End If End If End If End If Next i ' a raiz de que en las columnas G, H y demas columnas hacia la derecha ya no me copia valores que sean mayores a cero (0) me vi en la necesidad 'de entrar nuevamente a un nuevo ciclo ignoro si el if en vba tenga limitante ' For t = 4 To H2.Range("b" & Rows.Count).End(xlUp).Row ' Set b1 = H1.Range("A:A").Find(H2.Cells(t, "b"), lookat:=xlPart) ' ' If Not b1 Is Nothing And H1.Range("f" & b.Row) > 0 Then ' ' H1.Range("F" & b.Row).Copy ' H2.Cells(t, "G").PasteSpecial xlValues ' ' If Not b1 Is Nothing And H1.Range("f" & b.Row) > 0 Then ' ' H1.Range("G" & b.Row).Copy ' H2.Cells(t, "H").PasteSpecial xlValues ' ''MsgBox "Fin" ' End If ' End If 'Next t Application.CutCopyMode = False Application.ScreenUpdating = True End Sub Hola Cecilio, la condición tiene que ser mayor igual a 0, porque en la hoja 1 tienes valores (0)..
  24. Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean) ListBox1.BoundColumn = 2 ListBox1.TextColumn = 2 Hoja3.Range("D9") = ListBox1.Value Exit Sub End Sub Hola Xanito, copia este código. Saludos @Gerson Pineda
  25. Hola Sretamalb, revisa el adjunto. saludos @Antoni. Prueba (2).xlsm
×
×
  • Create New...

Important Information

Privacy Policy