Saltar al contenido
Te enseño 7 de los trucos que me permitieron trabajar 2 horas menos al día >>>

Cargar datos de la misma hoja de excel

EdwinGC
 Share

Recommended Posts

EdwinGC Novato

EdwinGC

publicado
publicado

Buen día comunidad 

Antes que nada este código lo encontré en la página Mehmet Ali Gokmen y me gustaría editar el llenado del framePerson del formulario frmMain.

Para este llenado el ejemplo es tomar del mismo libro una hoja llamada BaseVentan que cuenta con 38 columnas, el framePerson me gustaría llenarlos con la columna 2, 3, 8, 10, 11, 13, 27, 28 y 29, me gustaría que se mantenga toda la visualización y ejecución del userform.

 

Dejo el código espero que me puedan ayudar y de ante mano muchas gracias.

 

'********MOUSE MOVE ICON CODES*************************************************************************************************************
#If VBA7 And Win64 Then
    ' // 64bit
    Private Declare PtrSafe Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare PtrSafe Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
#Else
    ' // 32bit
    Private Declare Function LoadCursorBynum Lib "user32" Alias "LoadCursorA" (ByVal hInstance As Long, ByVal lpCursorName As Long) As Long
    Private Declare Function SetCursor Lib "user32" (ByVal hCursor As Long) As Long
#End If


Public WithEvents mForm             As MSForms.UserForm
Public WithEvents mPage             As MSForms.MultiPage
Public WithEvents mFrame            As MSForms.Frame
Public WithEvents actionFrame       As MSForms.Frame
Public WithEvents pageFrame         As MSForms.Frame
Public WithEvents TotalPageLabel    As MSForms.Label

Public WithEvents headerFrame       As MSForms.Frame
Public WithEvents headerLabel       As MSForms.Label

Public WithEvents tData             As MSForms.Label
Public WithEvents RowBack           As MSForms.Label
Public WithEvents ActionButton      As MSForms.Label

Public WithEvents ActionLabel        As MSForms.Label
Public WithEvents actionRowBack      As MSForms.Label

Public this                         As New clsPerson '#########
Public thisCol                      As New Collection
Public detCol                       As New Collection

Public LabelTop                     As Integer
Public LabelLeft                    As Integer
Public actionLabelTop               As Integer

Private Function MouseMoveIcon()
    Dim lngRet As Long
    lngRet = LoadCursorBynum(0&, 32649&)
    lngRet = SetCursor(lngRet)
End Function


Sub FormResize()
    On Error Resume Next
    With frmMain
        With mFrame
            .Width = frmMain.InsideWidth - mFrameWidth - 15
            .Height = frmMain.InsideHeight - .Top - 60
        End With
         With pageFrame
            .Left = mFrame.Width - pageFrame.Width - 20
            .Top = mFrame.Top + mFrame.Height + 15
         End With
         
         headerFrame.Width = mFrame.Width - 4
         actionFrame.Visible = False
         TotalPageLabel.Top = mFrame.Top + mFrame.Height + 10
         
         With frmMain.btnAddPerson '#########
            .Left = mFrame.Width - 100
            .ZOrder 0
         End With

         For i = 1 To rowCount
            With mFrame
                .Controls("ActionButton" & i).Left = mFrame.Width - 40
                .Controls("RowBack" & i).Width = mFrame.Width - 5
            End With
         Next
    End With
End Sub

Private Sub getTableData()
 
    Connect
    SQL = "Select * from tbl_Person"
    rs.Open SQL, cn, 1, 3
    rowCount = rs.RecordCount
End Sub

Function GetHeaderValue() As Variant
  headers = Array("ID", "First Name", "Last Name", "Email", "Phone", "Job", "City", "Gender", "Birth Date") '#########
                    
    GetHeaderValue = headers
End Function

Public Sub TableDataList(Optional params As String, Optional isHeader As Boolean = False)
Dim colWidth As Variant
Dim tDataTop As Variant
Dim k As Integer, i As Integer
Dim arr
Dim arr2 As Variant


Dim StartTime As Double
    Dim EndTime As Double
    Dim ElapsedTime As Double
    
    Set mForm = frmMain
    Set mPage = frmMain.MultiPage1
    Set mFrame = frmMain.framePerson '##########
    Set actionFrame = frmMain.actionFramePerson '##########
    Set pageFrame = frmMain.framePagingPerson '##########
    Set headerFrame = frmMain.frameHeaderPerson '##########
    Set TotalPageLabel = frmMain.lblTotalPagePerson '##########
    
    colWidth = Array(40, 125, 85, 140, 85, 0, 125, 85, 85, 0, 85, 85, 85, 85, 0, 0, 0, 85)
    tDataTop = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
       
       getTableData
       
        With rs
            colCount = .Fields.Count
            rowCount = .RecordCount
        End With
        
          '##########HEADERS##################################################
             If isHeader = True Then
                With headerFrame
                    .Clear
                    .Caption = ""
                    .BorderStyle = fmBorderStyleSingle
                    .BorderStyle = fmBorderStyleNone
                    .ZOrder 1
                    
                    LabelLeft = 17
                    
                    For i = 0 To UBound(GetHeaderValue)
                        Set headerLabel = .Controls.Add("Forms.Label.1", "headerLabel" & i)
                            With headerLabel
                                .Caption = GetHeaderValue(i)
                                .Left = LabelLeft
                                .Top = 8
                                .Width = colWidth(i)
                                .Font.Name = "Nunito Bold"
                                .Font.Size = 11
                                .ForeColor = HeaderColor
                                .WordWrap = False
                                .BackStyle = fmBackStyleTransparent
'                                .BorderStyle = fmBorderStyleSingle
'                                .BorderColor = RGB(212, 212, 212)
                                .Tag = i
                            LabelLeft = LabelLeft + .Width + 1
                            End With
                            
                            Set this = New clsPerson '##########
                            Set this.headerLabel = headerLabel
                            thisCol.Add this
                            
                            Set headerLabel = Nothing
                            
                    Next
                .Width = LabelLeft + 15
                End With
             End If
        '##########HEADERS##################################################

        
        
       
        
         With mFrame
             .Clear
             .Caption = ""
             .Width = mPage.Width - .Left - 10
             .Height = mPage.Height - .Top - 55
             .BorderStyle = fmBorderStyleSingle
             .BorderStyle = fmBorderStyleNone
            
        
        ' // The number of lines to come is adjusted according to the frame height.
             ListRows = ListRowCount(mFrame)
             LastRecVal = PageNumber * ListRows
            
             
             If rowCount > 0 Then
                arr = rs.GetRows
                
                  '// array Transpose to arr2
                  Dim rCount As Integer
                  rCount = UBound(arr, 2)
                   ReDim arr2(LBound(arr) To UBound(arr, 2), 0 To colCount)
                    X = 0: k = 0
                         For i = LBound(arr) To UBound(arr, 2)
                         '//so that it does not give an error when the parameter is empty.
                            If params <> Empty Then
                            '//We write the column order we want instead of '2' to search
                            '//according to the order of the headers we have added.
                                If InStr(1, arr(1, i), params, vbTextCompare) <> 0 Then
                                    For Y = 0 To colCount - 1
                                        arr2(X, Y) = arr(Y, i)
                                    Next
                                    X = X + 1
                                 End If
                             Else
                                For Y = 0 To colCount - 1
                                    arr2(X, Y) = arr(Y, i)
                                Next
                                X = X + 1
                             End If
                         Next
                          
                    Erase arr
                    arr = arr2
                    Erase arr2
                    TotalRecVal = X
                    rowCount = X
                    
                    

                 LabelTop = 0
                 If arrIndex > -1 Then _
                    arr = SelectionSort(arr, arrIndex) 'when HeaderLabel click,sorting data

                 For i = FirstRecVal - 1 To LastRecVal - 1 'rowCount
                        
                        If i <= UBound(arr) Then
                            If arr(i, 0) <> Empty Then
                            
        
                             Set RowBack = .Controls.Add("Forms.Label.1", "RowBack" & i + 1)
                                 With RowBack
                                     .Width = mFrame.Width - 5
                                     .Left = 1
                                     .Height = 40
                                     .Top = LabelTop
                                     .BorderStyle = fmBorderStyleSingle
                                     .BorderColor = RGB(212, 212, 212)
                                     .BackColor = vbWhite
                                 
                                     LabelLeft = 10
                                     For k = 0 To UBound(GetHeaderValue)
                                         Set tData = mFrame.Controls.Add("Forms.Label.1", GetHeaderValue(k) & i + 1)
                                             With tData
                                                 .Width = colWidth(k)
                                                 If arr(i, k) <> Empty Then
                                                 .Caption = arr(i, k)
                                                 Else
                                                    .Caption = ""
                                                 End If
                                                 .Font.Name = "Nunito Medium"
                                                 .Font.Size = 10
                                                 .Top = LabelTop + tDataTop(k) + 12
                                                 .Height = 30
                                                 .WordWrap = True
                                                 .BackStyle = fmBackStyleTransparent
    '                                             .BorderStyle = fmBorderStyleSingle
                                                 .Left = headerFrame.Controls("headerLabel" & k).Left
                                                 .ForeColor = vbBlack 'vbGrayText
                                                  LabelLeft = LabelLeft + .Width
                                       
                                            End With
                                            
                                            Set this = New clsPerson '#########
                                            Set this.tData = tData
                                            Set this.RowBack = RowBack
                                            Set this.mFrame = mFrame
                                            Set this.actionFrame = actionFrame
                                            thisCol.Add this
                                      Next
                         
                            Set ActionButton = mFrame.Controls.Add("Forms.Label.1", "ActionButton" & i + 1)
                                  With ActionButton
                                      .Left = mFrame.Width - 40
                                      .Font.Name = "myicons"
                                      .Font.Size = 18
                                      .Caption = ChrW("&HE099")
                                      .ForeColor = vbGrayText
                                      .Top = LabelTop + 10
                                      .AutoSize = True
                                      .BackStyle = fmBackStyleTransparent
                                     .Tag = arr(i, 0) & "-" & i + 1
                                  End With
                         LabelTop = LabelTop + .Height + 3
                         
'
                         
                         
                         End With 'RowBack End
                         
                        
                         
                         Set this = New clsPerson '#########
                         Set this.ActionButton = ActionButton
                         Set this.RowBack = RowBack
                         Set this.actionFrame = actionFrame
                         Set this.mPage = mPage
                         Set this.mFrame = mFrame
                         Set this.mForm = mForm
                         thisCol.Add this
                         Set ActionButton = Nothing
                      End If
                   End If
                Next

               
                  End If
                   
    

                '##########PAGING ELEMENT###############################
                 paging.AddPageElement mFrame, pageFrame, TotalPageLabel
                '##########PAGING ELEMENT###############################
         End With
        FormResize
End Sub


'**************ACTION FRAME***********************************************************************************************
Private Sub ActionButton_Click()
Dim actionLabelIcon As MSForms.Label
Dim actionLabelCaption() As Variant
Dim ActionIcon As Variant
    
    ActionIcon = Array("0033", "E0AC")
    actionLabelCaption = Array("Edit", "Delete!")
     
    With actionFrame
         .Clear
         .Caption = ""
         .BackColor = NavFrameColor
         .BorderStyle = fmBorderStyleSingle
'         .BorderStyle = fmBorderStyleNone
         .BorderColor = NavForeColor
         .Width = 100
         .Height = 100
         .Top = ActionButton.Top + mFrame.Top - mFrame.ScrollTop
         .Left = ActionButton.Left - .Width
         .ZOrder 0
         
         actionLabelTop = 10
         
         
         For i = 1 To UBound(actionLabelCaption) + 1
         
            Set ActionLabel = .Controls.Add("Forms.Label.1", "actionLabel" & i)
                With ActionLabel
                    .Caption = actionLabelCaption(i - 1)
                    .Font.Name = "Nunito Medium"
                    .Font.Size = 11
                    .ForeColor = NavForeColor
                    .BackStyle = fmBackStyleTransparent
                    .Left = 34
                    .Top = actionLabelTop
                    .Tag = Split(ActionButton.Tag, "-")(0) & "-" & Split(ActionButton.Tag, "-")(1) & "-" & i
'                    .WordWrap = False
'                    .AutoSize = True
                    .Width = actionFrame.Width
                   
                    
                Set actionLabelIcon = .Parent.Controls.Add("Forms.Label.1", "actionLabelIcon" & ActionLabel)
                    With actionLabelIcon
                        .Font.Name = "myicons"
                        .Font.Size = 14
                        .Caption = ChrW("&H" & ActionIcon(i - 1))
                        .Left = 10
                        .Top = ActionLabel.Top
                        .ForeColor = NavForeColor
                        .BackStyle = fmBackStyleTransparent
                        .AutoSize = True
            '            .BorderStyle = fmBorderStyleSingle
                        .ZOrder 1
                    End With
            
                actionLabelTop = actionLabelTop + .Height + 14
                End With
                
                Set this = New clsPerson
                Set this.ActionLabel = ActionLabel
                Set this.actionFrame = actionFrame
                Set this.mFrame = mFrame
                detCol.Add this
                
                Set ActionLabel = Nothing
                
        Next
        
                ' // Action Label Row Back
                Set actionRowBack = .Controls.Add("Forms.Label.1", "actionRowBack")
                    With actionRowBack
                        .Height = 28
                        .Visible = False
                        .Left = 0
                        .Width = actionFrame.Width - 2
                        .BackStyle = fmBackStyleTransparent
'                        .Picture = frmElement.ActionFrameRowBack.Picture
                        .ZOrder 1
                    End With
                
        .Height = actionLabelTop
        
        If .Top + .Height > mFrame.Top + mFrame.Height Then
            .Top = ActionButton.Top + mFrame.Top - .Height - mFrame.ScrollTop + 20
        End If
        
      .Visible = True
     End With
     
     rowBackColorExit True
     RowBack.BackColor = RowBackBackColor
End Sub

Private Sub ActionButton_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MouseMoveIcon
   
End Sub

Private Sub actionFrame_Click()

End Sub

Private Sub actionLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MouseMoveIcon
End Sub
Function GetRowValue(colIndex As Integer, rowIndex As Integer)
    head = GetHeaderValue(colIndex)
    GetRowValue = mFrame.Controls(head & rowIndex)

End Function


Private Sub ActionLabel_Click()
    Dim ActionOrder As Integer, ActionID As Integer
    Dim recOrder As Integer
    Dim accountName As String
    
    ActionID = Split(ActionLabel.Tag, "-")(0)
    recOrder = Split(ActionLabel.Tag, "-")(1)
   
    
    actionFrame.Visible = False
    Select Case ActionLabel.Caption

        Case Is = "Edit"
            Edit ActionID, recOrder
        Case Is = "Delete!"
            Delete ActionID
    End Select
    
End Sub
' headers = Array("ID", "First Name", "Last Name", "Email", "Phone", "Job", "City", "Gender","Birth Date") '#########
Sub Edit(ActionID As Integer, recOrder As Integer)
    With frmPerson
        .txtID = ActionID
        .txtFirstName = GetRowValue(1, recOrder)
        .txtLastName = GetRowValue(2, recOrder)
        .txtEmail = GetRowValue(3, recOrder)
        .txtPhone = GetRowValue(4, recOrder)
        .txtJob = GetRowValue(5, recOrder)
        .txtCity = GetRowValue(6, recOrder)
        .cbGender = GetRowValue(7, recOrder)
        .txtBirthDate = GetRowValue(8, recOrder)
        .Show
    End With
End Sub
Private Sub Delete(ActionID As Integer) '#########
    Dim answer As String
        answer = MsgBox("Person will be delete! Are you sure?", vbYesNo, "Alert Message!")
        If answer = vbYes Then
            SQL = "Delete from tbl_person where ID = " & ActionID
            cn.Execute SQL
            MsgBox "Person Deleted!"
            TableDataList frmMain.txtSearchPerson
        End If
End Sub

'**************ACTION FRAME***********************************************************************************************


Private Sub headerLabel_Click()

    arrIndex = headerLabel.Tag
        If SortDirection = "asc" Then
            SortDirection = "desc"
        ElseIf SortDirection = "desc" Then
            SortDirection = "asc"
        Else
            SortDirection = "asc"
        End If
    TableDataList
End Sub

Private Sub headerLabel_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    MouseMoveIcon
End Sub

Private Sub mForm_Click()
   rowBackColorExit
End Sub

Private Sub mFrame_Click()
    rowBackColorExit
End Sub

Private Sub mPage_Click(ByVal Index As Long)
    rowBackColorExit
End Sub

Private Sub RowBack_Click()

    rowBackColorExit
    RowBack.BackColor = RowBackBackColor
    
End Sub

Private Sub tData_Click()
    RowBack_Click
    actionFrame.Visible = False
    
End Sub

Sub rowBackColorExit(Optional actionFramevisible As Boolean = False)
    On Error Resume Next
    If actionFramevisible = False Then
        actionFrame.Visible = False
    End If
    For i = FirstRecVal To LastRecVal
        mFrame.Controls("RowBack" & i).BackColor = vbWhite
    Next
End Sub

 

 

EdwinGC Novato

EdwinGC

publicado
  • Autor
publicado

 Buen dia Antoni 

No me permite subir el archivo por el tamaño hay alguna otra forma de poder mandarlo para que puedan analisarlo 

 

gracias 

 

EdwinGC Novato

EdwinGC

publicado
  • Autor
publicado

Antonio buen día 

No pude subir el archivo ya lo intente mucho pero no se puede por el tamaño pero si me permites te dejo el link de donde descargue el proyecto, lo que requiero si me pueden ayudar

 

Es que en el Frame llamado framePerson  que en base al formulario esta conectado a una bese de access, en lugar de que se conecte a la base de datos de acces se carguen los datos de una hoja de excel del mimo libro ejemplo: la hoja se llama BaseVentas y contiene 38 columnas de las cuales me gustaría que se visualisaran en el framePerson las columnas  2, 3, 8, 10, 11, 13, 27, 28 y 29 respectiva mente y con sus respectivos formatos. 

 

Se que para el funcionamiento se tiene que mantener la conexión a access para el correcto funcionamiento por esa razón solo requiero que el único cambio sea el llenado del frame.

 

Espero haberme dado a entender ya que apenas voy iniciando en esto de la programación de antemano muchas gracias.

Dejo link de la página de YouTube del propietario del código 

 

https://youtu.be/-wWlSUcYDQM?si=NTOerTY8h8D9byXM

Saludos 

 

Conéctate para comentar

Podrás dejar un comentario después de conectarte



Conéctate ahora
 Share
Ir al listado de temas

  • 109 ¿Te parecen útiles los tips de las funciones? (ver tema completo)

    1. 1. ¿Te parecen útiles los tips de las funciones?


      • Sí
      • No
      • Ni me he fijado en ellos

  • Ayúdanos a mejorar la comunidad

    • Mantenimiento de la comunidad
      Donaciones recibidas este mes: 0.00 EUR
      Objetivo: 130.00 EUR

  • Archivos

  • Estadísticas de descargas

    • Archivos
      188
    • Comentarios
      98
    • Revisiones
      29
    Más información sobre "Cambios en el Control Horario"
    Última descarga
    Cambios en el Control Horario
    Por pegones1

    5    1

  • Crear macros Excel

  • Mensajes

    • jues
      Sumar Celdas Mediante Condición de Color

      Por jues · publicado

      Estimados amigos espero estén bien   Tengo este archivo que me ayuda a llevar las horas trabajadas al que necesito añadir en la Hoja5 (HHE) una fórmula que me cuente las Horas trabajadas en Días de Descanso (fines de semana y feriados), actualmente mediante una Regla de Formato Condicional se resaltan en amarillo el Dia de Semana y la Fecha de los Días de Descanso sin embargo el inconveniente se me presenta con los días feriados que cambian de posición de acuerdo a la fecha y cuando el mes comienza en día domingo por lo cual necesito una fórmula que me permita sumar los Días de Descanso cuando la Fecha que le corresponda este resaltada en Amarillo la sintaxis sería más o menos esta para la primera semana del mes de Enero de 2025: =SI('VTL1'!$I$7=AMARILLO;'VTL1'!$I8;0) + SI('VTL1'!$J$7=AMARILLO;'VTL1'!$J8;0) + SI('VTL1'!$K$7=AMARILLO;'VTL1'!$K8;0) + SI('VTL1'!$L$7=AMARILLO;'VTL1'!$L8;0) + SI('VTL1'!$M$7=AMARILLO;'VTL1'!$M8;0) + SI('VTL1'!$N$7=AMARILLO;'VTL1'!$N8;0) + SI('VTL1'!$O$7=AMARILLO;'VTL1'!$O8;0) Y así sucesivamente para el resto de las semanas, con los datos actuales el resultado esperado para la primera semana (I8:O8) sería 9 horas mientras que para el mes (Fila8) el resultado esperado seria 35 horas estos resultados deben reflejarse en la Celda “$Z7” de la Hoja5 (HHE) de modo tal que una vez haya completado la totalidad de la fórmula para el resto de las semanas del mes la pueda correr de Z27 hasta Z42 VTL - HHE_101128.xlsx
    • DiegoPC
      FORMULA PARA BUSCAR DIFERENTES RESULTADOS Y MOSTRARLOS

      Por DiegoPC · publicado

      Hola, veo que tienes 365, así que esta forma funcionará   Almacen.xlsx
    • jues
      Guardar Formulario en PDF

      Por jues · publicado

      Buenos días  @LeandroA espero estes bien Tengo un caso idéntico al planteado en la siguiente pregunta: Sin embargo, a diferencia de quien planteo originalmente la pregunta al correr el código no obtengo ningún resultado podrían ayudarme a resolver este inconveniente y que al hacer click en el Botón Guardar (CommandButton3) del Formulario RCS (frmrcs) el archivo pdf quede configurado con orientación vertical, márgenes superior, inferior, derecho e izquierdo = 1 y en página tamaño carta. Si acaso influye uso Microsoft Excel LTSC MSO (versión 2209 Compilación16.0.1.15629.20200) de 64 bits Mucho le sabre agradecer la ayuda que me pueda dar  RCS PRUEBA - copia.xlsm
    • DiegoLG
      Surtido de Mercancía

      Por DiegoLG · publicado

      @JSDJSDCon gusto mi estimado Para la opción 1: Sub Surtirhastadondealcanse() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 4 Dim filaFin As Integer: filaFin = 7 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Else solicitudes(i) = 0 End If surtido(i) = "POR FALTA STOCK" Next i ' Surtir de acuerdo al inventario disponible For i = 1 To numClientes If solicitudes(i) > 0 Then If inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) ElseIf inventario > 0 Then surtido(i) = inventario totalSurtido = totalSurtido + inventario inventario = 0 Else surtido(i) = "POR FALTA STOCK" End If End If Next i ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = "POR FALTA STOCK" Then .Value = surtido(i) .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Para la opción 2:   Sub surtirenpartesiguales() Dim ws As Worksheet Set ws = ThisWorkbook.Sheets(1) Dim filaInicio As Integer: filaInicio = 13 Dim filaFin As Integer: filaFin = 16 Dim colInventario As Integer: colInventario = 2 Dim colSolicitudesInicio As Integer: colSolicitudesInicio = 4 ' Columna C Dim colResultadoInicio As Integer: colResultadoInicio = 9 ' Columna I Dim colTotalSurtido As Integer: colTotalSurtido = 12 ' Columna L Dim colFinalInventario As Integer: colFinalInventario = 13 ' Columna M Dim numClientes As Integer: numClientes = 3 Dim fila As Integer, i As Integer For fila = filaInicio To filaFin Dim inventario As Double inventario = Val(ws.Cells(fila, colInventario).Value) Dim solicitudes(1 To 3) As Double Dim surtido(1 To 3) As Variant Dim totalSurtido As Double: totalSurtido = 0 Dim totalPedido As Double: totalPedido = 0 ' Leer solicitudes For i = 1 To numClientes If IsNumeric(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) Then solicitudes(i) = CDbl(ws.Cells(fila, colSolicitudesInicio + i - 1).Value) totalPedido = totalPedido + solicitudes(i) Else solicitudes(i) = 0 End If surtido(i) = 0 Next i ' Si hay suficiente inventario, surtir lo que el cliente pide If inventario >= totalPedido Then For i = 1 To numClientes If solicitudes(i) > 0 And inventario >= solicitudes(i) Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) End If Next i Else ' Reparto base igualitario Dim baseSurtido As Long baseSurtido = Int(inventario / numClientes) For i = 1 To numClientes If solicitudes(i) > 0 Then If solicitudes(i) <= baseSurtido Then surtido(i) = solicitudes(i) inventario = inventario - solicitudes(i) totalSurtido = totalSurtido + solicitudes(i) Else surtido(i) = baseSurtido inventario = inventario - baseSurtido totalSurtido = totalSurtido + baseSurtido End If End If Next i ' Repartir sobrante restante uno por uno, respetando lo pedido Do While inventario > 0 For i = 1 To numClientes If surtido(i) < solicitudes(i) Then surtido(i) = surtido(i) + 1 totalSurtido = totalSurtido + 1 inventario = inventario - 1 If inventario = 0 Then Exit For End If Next i Loop End If ' Escribir resultados en las columnas correspondientes para cada cliente For i = 1 To numClientes With ws.Cells(fila, colResultadoInicio + i - 1) If surtido(i) = 0 Then .Value = "POR FALTA STOCK" .Font.Color = vbRed Else .Value = surtido(i) .Font.Color = vbBlack End If End With Next i ' Escribir total surtido y existencia final ws.Cells(fila, colTotalSurtido).Value = totalSurtido ws.Cells(fila, colFinalInventario).Value = inventario Next fila MsgBox "Resultado surtido cargado con éxito...", vbInformation End Sub Saludos, Diego
    • jose_alk
      FORMULA PARA BUSCAR DIFERENTES RESULTADOS Y MOSTRARLOS

      Por jose_alk · publicado

      Buenos dias.  Estoy trabajando en una hoja para poder llevar un control de un pequeño almacén.  Tengo un pedido con varias líneas y "lotes" y necesito sacar las ubicaciones que coincidan con la referencia y lote que pone en el pedido. El problema viene cuando tengo la misma referencia y mismo lote en ubicaciones diferentes y necesito sacar la información en columnas diferentes. No se si  me he explicado bien, pero creo que con el ejemplo adjunto se entiende mejor. Agradecería mucho si me pudieran ayudar  Libro1.xlsx

  • Visualizado recientemente

    • No hay usuarios registrado para ver esta página.
×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.