Extracting and Writing

[Michael168]

I want extract the cells value (Sheet1) under conditions meet and write
them to (Sheet2) in one row.
How to code the below module.

e.g. of my spreadsheet.

Draw A B C D E F G
200 06 07 09 10 11 12 13
201 01 02 03 04 05 06 07
202 02 03 04 05 06 07 08
203 03 04 05 06 07 08 09
204 04 05 06 07 08 09 10
205 05 06 07 08 09 10 11
206 06 07 08 09 10 11 12
207 07 08 09 10 11 12 13
208 08 09 10 11 12 13 14
209 09 10 11 12 13 14 15
210 01 02 03 13 14 15 16

The inner loop,

The checking module will start from the last row of the worksheet and
skips backward (in this e.g. Draw 201).
It will store the values from Cell A to Cell F (Column 2 to Column 7)
as 6 variables.
Using the six variables it will check against previous 1 row cells
value ( Cell A to Cell G - Column 2 to Column 8).
Let say in this example, it find that there are 3 cells value are the
same. i.e. 13,14,15.
It will write to Sheet2 row 100, column 1 will hold draw i.e. 210,
column 2 will have 13,14,15, & column 3 will have 3 which means there
are 3 numbers found.
Next it skip the previous 2 row to Draw 208 and do the check again. It
find there are two cells value the same, i.e. 13,14 but these 2 values
had already exists in Draw 209, so in Sheet2 column 4 will be empty and
column 5 will be 0.
Next it skip again and repeat the procedure and eventually at Draw 203
it find the cell value of 03, this value will be written to Sheet2 as
well.
Next it skip again and find at Draw 202 there are 2 cells value, i.e.
02,03 but it will write only 02 because 03 has been found previously in
Draw 203.
Eventually the last row at Draw 201, it found 3 cells value are the
same, i.e. 01,02,03 but only 01 will be written to sheet because 02 &
03 have been found respectively in Draw 202 & Draw 203. When it has
found 6 numbers that are the same the inner will stop else it continue
until row 200 and stop the inner loop.

So in sheet2 at row/line 100 the output of the columns will like
below.

A B C D E F G H I J K L M N O P Q R S T U (21 Columns in a row)

210 in col A
13,14,15 in col B , 3 in col C
empty in col D , 0 in col E
empty in col F , 0 in col G
empty in col H , 0 in col I
empty in col J , 0 in col K
empty in col L , 0 in col M
03 in col N , 1 in col O
02 in col P , 1 in col Q
01 in col R , 1 in col S
empty in col T, 0 in col U

The outer loop,

Once it finished the first last row checking, then it will start all
over again from Row 209 and store the value from Col 2 to Col 7 as 6
new variables and use them to check against next previous 10 rows 7
columns (Col 2 to Col 8). The outer loop will continue for 100 times
and the inner loop continues for 10 times only.

At the end of the procedure in Sheet2 will have a summary report of 100
rows by 21 columns answer.

I hope the above routine is clear and can be understand.

 

[Dick Kusleika]

Michael

Try this and let me know if you have any problems with it.

Sub MakeReport()

Dim Rng As Range
Dim cell As Range
Dim i As Long, j As Long, k As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim LastRow As Long
Dim ChkVal(1 To 6) As String
Dim Matches As String
Dim sh2Row As Long

Set sh1 = ThisWorkbook.Sheets("sheet1")
Set sh2 = ThisWorkbook.Sheets("Sheet2")
sh2Row = 100

'Find the last row
LastRow = sh1.Range("A65536").End(xlUp).Row

'Loop from last row to -100
For i = LastRow To (LastRow - 99) Step -1

'Load values into an array
With sh1.Cells(i, 1)
For j = 1 To 6
ChkVal(j) = .Offset(, j).Text
Next j

'Write draw # to sheet 2
sh2.Cells(sh2Row, 1).Value = .Value

'Loop through above rows to look for dups
For k = i - 1 To (i - 11) Step -1

'Loop through cell of above rows and
'compare to array values
For Each cell In sh1.Range("B" & k, "H" & k)
For j = 1 To 6
If cell.Value = ChkVal(j) Then
Matches = Matches & cell.Value & ","
ChkVal(j) = ""
End If
Next j
Next cell

'Write matches to sh2
If Len(Matches) = 0 Then
sh2.Cells(sh2Row, (i - k) * 2).Value = Matches
Else
sh2.Cells(sh2Row, ((i - k) * 2)).Value = _
Left(Matches, Len(Matches) - 1)
End If
sh2.Cells(sh2Row, ((i - k) * 2) + 1).Value = _
Len(Matches) - Len(Replace(Matches, ",", ""))

'Clear matches
Matches = ""

Next k
End With

'increment row
sh2Row = sh2Row - 1

'Clear array for next row
For j = 1 To 6
ChkVal(j) = 0
Next j
Next i

End Sub