Query & Write

[Michael168]

Datasheet contains
Row 1( Header)----> Date Na Nb Nc Nd
Row 2 31/10/03 1 8 3 4
Row 3 01/11/03 5 8 2 9

Querysheet contains
Row 1(Header)----> Date Rowno 1 3 5 6 9
Row 2 31/10/03 2 0 0 1 0 1

Query conditions are:
Look in the datasheet at row2 for a value of 1, if found, then look at
next row i.e. row3 for value found in the querysheet in this case are
1,3,5,6,9 . If found, it will write the date & rowno of row2 of
datasheet and the value of 1 & 0 will be insert accordingly to the
column.
This macro will run the loops from row2 of datasheet until the last
row.
Thank you for helping.

 

[Dick Kusleika]

Michael

Try this

Sub QrySheet()

Dim DSh As Worksheet
Dim QSh As Worksheet
Dim i As Long, k As Long
Dim cell As Range
Dim Rng As Range
Dim MtchFnd As Variant

With ThisWorkbook
Set DSh = .Worksheets("Datasheet")
Set QSh = .Worksheets("Querysheet")
End With

Set Rng = DSh.Range("a2", DSh.Range("A65536").End(xlUp))
k = 1

For Each cell In Rng
If InStr("," & cell.Offset(0, 1).Value & _
"," & cell.Offset(0, 2).Value & _
"," & cell.Offset(0, 3).Value & _
"," & cell.Offset(0, 4).Value & ",", ",1,") > 0 Then

k = k + 1
QSh.Cells(k, 1).Value = cell.Value
QSh.Cells(k, 2).Value = cell.Row
QSh.Range("C" & k & ":G" & k).Value = 0

For i = 1 To 4
MtchFnd = Application.Match(cell.Offset(1, i).Value, _
QSh.Range("c1:G1"), False)

If Not IsError(MtchFnd) Then
QSh.Range("b" & k).Offset(0, MtchFnd).Value = 1
End If
Next i
End If
Next cell

End Sub