Looking at data sheet and then transferring data according to date to fixed range

Hi

I am using a Userform to find data in a sheet called Team A.With the selected date and ranges in userform it then searches sheet Team A.It then transfer that information to a sheet called Group A.

The date will be in Column B.It will look at Planned stops ( range K8:M1000) that match that date and transfer to sheet Group A range O6:Q11, same for Unplanned stops - internal & Unplanned Stops - external..(internal & external stops leaves out the transfer of Part and Fault)

I will do the same for sheets Group B and Group C

Thanks

Hi

Put this code in the Userform module.

Code:

---

Private Sub CommandButton1_Click()
   
    Dim wksSource  As Worksheet
    Dim wksDest    As Worksheet
    Dim n          As Long
    Dim i          As Long
    Dim j          As Long
    Dim lngDate    As Long
    Dim rngDest    As Range
    Dim Data, arrOP()
   
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
    j = Me.ListBox1.ListIndex
    If j = -1 Then Exit Sub
   
    lngDate = CLng(DateValue(Me.ComboBox1.Value))
   
    Set wksSource = ThisWorkbook.Worksheets("team a")
    Set wksDest = ThisWorkbook.Worksheets("group a")
   
    Data = wksSource.Range("b8:v" & wksSource.Range("b" & wksSource.Rows.Count).End(xlUp).Row).Value2
   
    If IsArray(Data) Then
        ReDim arrOP(1 To UBound(Data, 1), 1 To 3)
        For i = 1 To UBound(Data, 1)
            If Data(i, 1) = lngDate Then
                n = n + 1
                Select Case j 'Listbox Selection
                    Case 0 'Planned stop
                        arrOP(n, 1) = CDate(Data(i, 1)) 'date
                        arrOP(n, 2) = Data(i, 10) 'Reason
                        arrOP(n, 3) = Data(i, 11) 'time
                    Case 1
                        arrOP(n, 1) = CDate(Data(i, 1)) 'date
                        arrOP(n, 2) = Data(i, 13) 'part
                        arrOP(n, 3) = Data(i, 16) 'time
                    Case 2
                        arrOP(n, 1) = CDate(Data(i, 1)) 'date
                        arrOP(n, 2) = Data(i, 18) 'Reason
                        arrOP(n, 3) = Data(i, 20) 'time
                End Select
            End If
        Next
        If n Then
            Set rngDest = wksDest.Range("o5").Offset(j * 9 + 1)
            rngDest.Resize(6, 3).ClearContents
            rngDest.Resize(n, 3) = arrOP
        End If
    End If
   
    Unload Me
   
End Sub

---

Hi Admin

I placed in the userform the code

I placed some dummy figures in the sheet but it did not transfer

Have I missed something

Thanks

That's because the date is not matching with the data.

My apologies

It does though place more then 1 date in each grouping.It also does not find the last entry as it places down the rows...it is impressive though

Thanks

Hi

Try this.

Code:

---

Private Sub CommandButton1_Click()
   
    Dim wksSource  As Worksheet
    Dim wksDest    As Worksheet
    Dim n          As Long
    Dim i          As Long
    Dim j          As Long
    Dim lngDate    As Long
    Dim rngDest    As Range
    Dim Data, arrOP()
   
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
    j = Me.ListBox1.ListIndex
    If j = -1 Then Exit Sub
   
    lngDate = CLng(DateValue(Me.ComboBox1.Value))
   
    Set wksSource = ThisWorkbook.Worksheets("team a")
    Set wksDest = ThisWorkbook.Worksheets("group a")
   
    Data = wksSource.Range("b8:v" & wksSource.Range("b" & wksSource.Rows.Count).End(xlUp).Row).Value2
   
    If IsArray(Data) Then
        ReDim arrOP(1 To UBound(Data, 1), 1 To 3)
        For i = 1 To UBound(Data, 1)
            If Data(i, 1) = lngDate Then
                Select Case j 'Listbox Selection
                    Case 0 'Planned stop
                        'check for data
                        If Len(Data(i, 10)) Then
                            n = n + 1
                            arrOP(n, 1) = CDate(Data(i, 1)) 'date
                            arrOP(n, 2) = Data(i, 10) 'Reason
                            arrOP(n, 3) = Data(i, 11) 'time
                        End If
                    Case 1
                        'check for data
                        If Len(Data(i, 13)) Then
                            n = n + 1
                            arrOP(n, 1) = CDate(Data(i, 1)) 'date
                            arrOP(n, 2) = Data(i, 13) 'part
                            arrOP(n, 3) = Data(i, 16) 'time
                        End If
                    Case 2
                        'check for data
                        If Len(Data(i, 18)) Then
                            n = n + 1
                            arrOP(n, 1) = CDate(Data(i, 1)) 'date
                            arrOP(n, 2) = Data(i, 18) 'Reason
                            arrOP(n, 3) = Data(i, 20) 'time
                        End If
                End Select
            End If
        Next
        If n Then
            Set rngDest = wksDest.Range("o5").Offset(j * 9 + 1)
            rngDest.Resize(6, 3).ClearContents
            rngDest.Resize(n, 3) = arrOP
        End If
    End If
   
    Unload Me
   
End Sub

---

Thanks Admin

I learnt a bit and changed the code so that i included the comments as well.It works so i guess i got it correct.Also added a delete code.

My only request is how do i have all 3 items in the listbox transfer at the same time.Press the transfer button once and the 3 listed are transfer simultaneously

Thank you for your help

Hi

Remove all the codes from the userform module and put this code.

Code:

---

Dim Data
Dim arrOP_PS(1 To 6, 1 To 4), PSCounter    As Long
Dim arrOP_MSI(1 To 6, 1 To 4), MSICounter  As Long
Dim arrOP_MSE(1 To 6, 1 To 4), MSECounter  As Long

Private Sub CommandButton1_Click()
   
    Dim wksSource  As Worksheet
    Dim wksDest    As Worksheet
    Dim i          As Long
    Dim j          As Long
    Dim p          As Long
    Dim lngDate    As Long
    Dim rngDest    As Range
    Dim LB()        As Long
   
    If Me.ComboBox1.ListIndex = -1 Then Exit Sub
    If Me.ListBox1.ListIndex = -1 Then Exit Sub
   
    With Me.ListBox1
        ReDim LB(1 To .ListCount)
        For j = 0 To .ListCount - 1
            If .Selected(j) Then
                p = p + 1
                LB(p) = j
            End If
        Next
    End With
    If p Then
        n = 0
        lngDate = CLng(DateValue(Me.ComboBox1.Value))
       
        Set wksSource = ThisWorkbook.Worksheets("team a")
        Set wksDest = ThisWorkbook.Worksheets("group a")
       
        Data = wksSource.Range("b8:v" & wksSource.Range("b" & wksSource.Rows.Count).End(xlUp).Row).Value2
       
        If IsArray(Data) Then
            For i = 1 To UBound(Data, 1)
                If Data(i, 1) = lngDate Then
                    CREATE_OUTPUT i, LB
                End If
            Next
            If PSCounter Then
                wksDest.Range("O6").Resize(UBound(arrOP_PS, 1), UBound(arrOP_PS, 2)).ClearContents
                wksDest.Range("O6").Resize(PSCounter, UBound(arrOP_PS, 2)) = arrOP_PS
            End If
            If MSICounter Then
                wksDest.Range("O15").Resize(UBound(arrOP_MSI, 1), UBound(arrOP_MSI, 2)).ClearContents
                wksDest.Range("O15").Resize(MSICounter, UBound(arrOP_MSI, 2)) = arrOP_MSI
            End If
            If MSECounter Then
                wksDest.Range("O24").Resize(UBound(arrOP_MSE, 1), UBound(arrOP_MSE, 2)).ClearContents
                wksDest.Range("O24").Resize(MSECounter, UBound(arrOP_MSE, 2)) = arrOP_MSE
            End If
        End If
    End If
    Unload Me
   
End Sub

Private Sub UserForm_Initialize()

    ComboBox1.List = [transpose(text(today()-6+row(1:6),"dd-mmm-yyyy"))]
   
    vList = ("PLANNED STOPS,UNPLANNED STOPS-INTERNAL,UNPLANNED STOPS-EXTERNAL")
    ListBox1.List = Split(Mid(vList, 1), ",")
   
End Sub

Private Sub CREATE_OUTPUT(ByVal CurrentRow As Long, ByRef LB_Selection() As Long)
   
    Dim i As Long
    Dim Flg0    As Boolean
    Dim Flg1    As Boolean
    Dim Flg2    As Boolean
   
    For i = LBound(LB_Selection) To UBound(LB_Selection)
        Select Case LB_Selection(i)
            Case 0 'Planned stop
                'check for data
                If Len(Data(CurrentRow, 10)) Then
                    If Not Flg0 Then
                        PSCounter = PSCounter + 1
                        arrOP_PS(PSCounter, 1) = CDate(Data(CurrentRow, 1)) 'date
                        arrOP_PS(PSCounter, 2) = Data(CurrentRow, 10) 'Reason
                        arrOP_PS(PSCounter, 3) = Data(CurrentRow, 11) 'time
                        arrOP_PS(PSCounter, 4) = Data(CurrentRow, 12) 'comment
                        Flg0 = True
                    End If
                End If
            Case 1
                'check for data
                If Len(Data(CurrentRow, 13)) Then
                    If Not Flg1 Then
                        MSICounter = MSICounter + 1
                        arrOP_MSI(MSICounter, 1) = CDate(Data(CurrentRow, 1)) 'date
                        arrOP_MSI(MSICounter, 2) = Data(CurrentRow, 13) 'part
                        arrOP_MSI(MSICounter, 3) = Data(CurrentRow, 16) 'time
                        arrOP_MSI(MSICounter, 4) = Data(CurrentRow, 17) 'comment
                        Flg1 = True
                    End If
                End If
            Case 2
                'check for data
                If Len(Data(CurrentRow, 18)) Then
                    If Not Flg2 Then
                        MSECounter = MSECounter + 1
                        arrOP_MSE(MSECounter, 1) = CDate(Data(CurrentRow, 1)) 'date
                        arrOP_MSE(MSECounter, 2) = Data(CurrentRow, 18) 'Reason
                        arrOP_MSE(MSECounter, 3) = Data(CurrentRow, 20) 'time
                        arrOP_MSE(MSECounter, 4) = Data(CurrentRow, 21) 'comment
                        Flg2 = True
                    End If
                End If
        End Select
    Next
End Sub

---

Hi Admin

Excellent and thanks

Wish I could code like that

Hi Admin

I updated the code by adding a extra column to the code.It works but i cannot workout how to clear the extra column.Where do i change please?

Also i plan on adding another 2 sheets called Team B and Team C.......should i just use the code for Team A and alter to suit Team B and Team C or how would the code be altered to include Team B and Team C with the code already for Team A

Thank you