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

Hi,

Try this ("under" CLEAR DATA button) code:

Code:

---

Private Sub CommandButton1_Click()
 Range("O6:S11,O15:S20,O24:S29").ClearContents
 MsgBox "Data Has Been Deleted"
End Sub

---

@ Ingolf please use code tags :)

How would you decide which team's data go to which which sheet ?

Hi

A userform picks which sheet to transfer the data to.

Thanks

Upload the userform.

Hi

This code worked until I added Team B and Team C....there are sheets now called TEAM A,Team B and Team C

Also I need the Combobox2 to differentiate between Day,Afternoon and Night when transferring data from TEAM A,Team B and Team C

Code:

---

Dim Data
Dim arrOP_PS(1 To 6, 1 To 5), PSCounter    As Long
Dim arrOP_MSI(1 To 6, 1 To 5), MSICounter  As Long
Dim arrOP_MSE(1 To 6, 1 To 5), 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,TEAM B,TEAM C")
        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()-10+row(1:6),"dd-mmm-yyyy"))]
   
    vList = ("PLANNED STOPS,UNPLANNED STOPS-INTERNAL,UNPLANNED STOPS-EXTERNAL")
    ListBox1.List = Split(Mid(vList, 1), ",")
   
    vList = ("DAYS,AFTERNOON,NIGHT")
    ComboBox2.List = Split(Mid(vList, 1), ",")
   
    vList = ("TEAM A,TEAM B,TEAM C")
    ComboBox3.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, 2) 'SHIFT
                        arrOP_PS(PSCounter, 3) = Data(CurrentRow, 10) 'Reason
                        arrOP_PS(PSCounter, 4) = Data(CurrentRow, 11) 'time
                        arrOP_PS(PSCounter, 5) = 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(PSCounter, 2) = Data(CurrentRow, 2) 'SHIFT
                        arrOP_MSI(MSICounter, 3) = Data(CurrentRow, 13) 'part
                        arrOP_MSI(MSICounter, 4) = Data(CurrentRow, 16) 'time
                        arrOP_MSI(MSICounter, 5) = 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(PSCounter, 2) = Data(CurrentRow, 2) 'SHIFT
                        arrOP_MSE(MSECounter, 3) = Data(CurrentRow, 18) 'Reason
                        arrOP_MSE(MSECounter, 4) = Data(CurrentRow, 20) 'time
                        arrOP_MSE(MSECounter, 5) = Data(CurrentRow, 21) 'comment
                        Flg2 = True
                    End If
                End If
        End Select
    Next
End Sub

---

The sheets have been added and although it does transfer the info it still produces a error 9 - Subscript Out Of Range....All sheets are in workbook and spelt correctly....could it be in the Array or Loop
It also in the userform have a combobox for Day,Afternoon and Night but it transfers all across.Need the code to just transfer what is selected from the combobox (could be a listbox as well).If day selected then only Day for the selected date,,,same for afternoon and night unless All selected in which all are transferred (DAy,Afternnon & Night)

Code:

---

Dim Data
Dim arrOP_PS(1 To 6, 1 To 5), PSCounter    As Long
Dim arrOP_MSI(1 To 6, 1 To 5), MSICounter  As Long
Dim arrOP_MSE(1 To 6, 1 To 5), 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 wksDest = ThisWorkbook.Worksheets("GROUP A")
       
        For Each TabName In Array("TEAM A", "TEAM B", "TEAM C")
            Set wksSource = ThisWorkbook.Worksheets(TabName)


       
        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
   
    Next TabName
    End If
 
 
End Sub

Private Sub UserForm_Initialize()

    ComboBox1.List = [transpose(text(today()-10+row(1:6),"dd-mmm-yyyy"))]
   
    vList = ("TEAM A,TEAM B,TEAM C")
    ComboBox3.List = Split(Mid(vList, 1), ",")
   
    vList = ("PLANNED STOPS,UNPLANNED STOPS-INTERNAL,UNPLANNED STOPS-EXTERNAL")
    ListBox1.List = Split(Mid(vList, 1), ",")
   
    vList = ("ALL,DAYS,AFTERNOON,NIGHT")
    ComboBox2.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, 2) 'SHIFT
                        arrOP_PS(PSCounter, 3) = Data(CurrentRow, 10) 'Reason
                        arrOP_PS(PSCounter, 4) = Data(CurrentRow, 11) 'time
                        arrOP_PS(PSCounter, 5) = 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(PSCounter, 2) = Data(CurrentRow, 2) 'SHIFT
                        arrOP_MSI(MSICounter, 3) = Data(CurrentRow, 13) 'part
                        arrOP_MSI(MSICounter, 4) = Data(CurrentRow, 16) 'time
                        arrOP_MSI(MSICounter, 5) = 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(PSCounter, 2) = Data(CurrentRow, 2) 'SHIFT
                        arrOP_MSE(MSECounter, 3) = Data(CurrentRow, 18) 'Reason
                        arrOP_MSE(MSECounter, 4) = Data(CurrentRow, 20) 'time
                        arrOP_MSE(MSECounter, 5) = Data(CurrentRow, 21) 'comment
                        Flg2 = True
                    End If
                End If
        End Select
    Next
End Sub

---