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

**Ingolf** · 12-20-2013, 03:06 PM

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

**Admin** · 12-20-2013, 09:32 PM

@ Ingolf please use code tags

**Admin** · 12-20-2013, 09:39 PM

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

**jeff** · 12-21-2013, 08:17 AM

Hi

A userform picks which sheet to transfer the data to.

Thanks

**Admin** · 12-21-2013, 12:18 PM

Upload the userform.

**jeff** · 12-21-2013, 01:06 PM

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

**jeff** · 12-23-2013, 03:44 PM

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