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

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

---