Extracting data from a spreadsheet and putting it in a form

[Bill]

Hello I’m Bill
I’m trying to write a VBA code to transfer data from a spread sheet to a form by using a if function. I want it to move the data when I post the date in the form A7. I have a spread sheet with 500 rows and 13 columns. I want to move curtain data into the form. And there are some blanks in the spread sheet. This will give you a idea what I’m trying to do.
If cost A6:A500 has the date that enter in the form, then If C6:500 has a code of 50040 it should copy over B E F G K in form .B copied into Form A15:A26, E copied into Form E15:E26, F copied into the formF15:F26 G copied into the formH15:H26, K copied into the formI15:I26 and have it loop until it get a empty cell in the form or fill up row 26.
If cost A6:A500 has the date that enter in the form, then If C6:500 has a code of 50000 it should copy over B D E F G K in form .B copied into Form D2840, D copied into Form B28:B40, E copied into Form G28:G40, F copied into the form H28:H40 G copied into the I28:I40, K copied into the form J28:J40 and have it loop until it get a empty cell in the form or fill up row 40.
Thank for your help on this
Bill

[gsnidow]

Bill, when you say "form", are you talking about a user form, like you would add via the vba project, and call with "userform1.show"? Or are you talking about worksheets in the same (or other, for that matter) workbook, that have been formatted to restrict data entry to what you want the user to do?

Greg

[Bill]

Bill, when you say "form", are you talking about a user form, like you would add via the vba project, and call with "userform1.show"? Or are you talking about worksheets in the same (or other, for that matter) workbook, that have been formatted to restrict data entry to what you want the user to do?

Greg

The user form is just a another sheet like the spreadsheet in excel

[Bill]

It just another worksheet in the same workbook

[gsnidow]

Why don't you attach a copy of your workbook with some sample data populated, and tell us specifically what you want to happen and why. That would give us a place to start. Your initial description is somewhat hard to follow, but sounds basically easy enough. Remember, we can't see what you see.

Greg

[Bill]

I would like all the cell on the Dwr worksheet with whit background and black number or letters

[gsnidow]

Bill, put this code in a worksheet change event in sheet "DWR". A couple of things to note are in the comments of the code, so I suggest you read them. There may be a more elegant solution, as I really have not learned anything new in VBA since Excel 2003, but this should get you in the ball park.

Greg

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
'****
'   Caveats:
'       1) assumes the item rows 15:26 and 28:40 on sheet "DWR" will be blank.
'           If not, the data will be overwritten.
'       2) code does not do any formatting, so you may want to add it.
'       3) anything else is also possible

    Dim WSFrom As Worksheet
    Dim WSTo As Worksheet
    Dim dtTarget As Date
    Dim FromRange As Range
    Dim i As Long, j As Long
    Dim LastRow As Long
    Dim c As Variant
    Dim RowCount As Long
    Dim arFrom()
    
    If Target.Address <> "$A$7" Then
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Set WSFrom = ActiveWorkbook.Sheets("Cost")
    Set WSTo = ActiveWorkbook.Sheets("DWR")
    
    dtTarget = WSTo.Cells(7, 1).Value
    RowCount = 0
    
    ' Here we are getting the range of the target date in worksheet "Cost".
    ' If it is not found, we will exit.
    With WSFrom
        LastRow = .Cells(6, 1).End(xlDown).Row
        For i = 6 To LastRow Step 1
            If .Cells(i, 1).Value = dtTarget Then
                ' Then i is the row of the first instance of our target date.
                Exit For
            End If
        Next i
        
        ' If i >= the value of LastRow, then we know we have searched
        ' the entire range, and did not find our target date, so exit.
        If i > LastRow Then
            MsgBox ("Target date not found")
            Exit Sub
        End If
        
        For j = i To LastRow Step 1
            If .Cells(j, 1).Value <> dtTarget Then
                ' Then we know we have encountered the first instance of
                ' a date that is not our target.
                j = j - 1
                Set FromRange = .Range(.Cells(i, 1), .Cells(j, 1))
                Exit For
            End If
        Next j
    End With
    
    ' Look for code 50040 first, and gather the values if any
    For Each c In FromRange
        If c.Offset(0, 2).Value = 50040 Then
            ReDim Preserve arFrom(1 To 5, 1 To RowCount + 1)
            arFrom(1, RowCount + 1) = c.Offset(0, 1).Value
            arFrom(2, RowCount + 1) = c.Offset(0, 4).Value
            arFrom(3, RowCount + 1) = c.Offset(0, 5).Value
            arFrom(4, RowCount + 1) = c.Offset(0, 6).Value
            arFrom(5, RowCount + 1) = c.Offset(0, 10).Value
            RowCount = RowCount + 1
        End If
    Next c
    
    ' Populate the values in the form.  You may have to do some formatting
    ' of the target cells in your form here, as the code as it is now does
    ' not do any formatting.
    
'**** Notice for array columns 4 and 5, we are shifting the column of the target
    ' cell one to the right.  I don't know if it is my Excel or not, but every time
    ' I ran it, the down time was populated in the end time field.  It may have
    ' something to do with the time fields, but you may have to tweak this.
    With WSTo
        For i = 1 To UBound(arFrom) Step 1
            If 15 + i - 1 <= 26 Then
                On Error Resume Next
                .Cells(15 + i - 1, 1).Value = arFrom(1, i)
                .Cells(15 + i - 1, 5).Value = arFrom(2, i)
                .Cells(15 + i - 1, 6).Value = arFrom(3, i)
                .Cells(15 + i - 1, 8).Value = arFrom(4, i) '**** you may need to change 8 to 7 here
                .Cells(15 + i - 1, 9).Value = arFrom(5, i) '**** you may need to change 9 to 8 here
            Else
                Exit For
            End If
        Next i
    End With
    
    ' Reset the rowcount, and get the values for code 50000
    ' The rest is the same.
    RowCount = 0
    ReDim arFrom(1 To 6, 1 To 1)
    For Each c In FromRange
        If c.Offset(0, 2).Value = 50000 Then
            ReDim Preserve arFrom(1 To 6, 1 To RowCount + 1)
            arFrom(1, RowCount + 1) = c.Offset(0, 3).Value
            arFrom(2, RowCount + 1) = c.Offset(0, 1).Value
            arFrom(3, RowCount + 1) = c.Offset(0, 4).Value
            arFrom(4, RowCount + 1) = c.Offset(0, 5).Value
            arFrom(5, RowCount + 1) = c.Offset(0, 6).Value
            arFrom(6, RowCount + 1) = c.Offset(0, 10).Value
            RowCount = RowCount + 1
        End If
    Next c
    
    With WSTo
        For i = 1 To UBound(arFrom) Step 1
            If 28 + i - 1 <= 40 Then
                On Error Resume Next
                .Cells(28 + i - 1, 1).Value = arFrom(1, i)
                .Cells(28 + i - 1, 4).Value = arFrom(2, i)
                .Cells(28 + i - 1, 7).Value = arFrom(3, i)
                .Cells(28 + i - 1, 8).Value = arFrom(4, i)
                .Cells(28 + i - 1, 9).Value = arFrom(5, i)
                .Cells(28 + i - 1, 10).Value = arFrom(6, i)
            Else
                Exit For
            End If
        Next i
    End With
    
    Application.ScreenUpdating = True
        
End Sub