10 million for UK
Automating the processing especially the sort routine so 1000s of
sorts can be done in series overnight if required. Also converting
between limits For loops to Do until EOF, also passing
variables to file names. Routines placed between HTML Horizontal Rules.
Processed over the week commencing 08 July 2004.
' change date (jul08 ) using Word/Edit/Replace
' Generating 10 loci x2 profiles
' directing pairs and first divider
Dim ph(20)
Dim pb(20)
' initialising Random Number Generator - RNG
count9 = 0
count8 = 0
Randomize
a = 214013
c = 2531011
x0 = Timer
z = 2 ^ 24
' 1 file 'jul08 g' for original, un-directed pairs, source data.
' This file is necessary to check on the performance of the RNG
' when a matched pair is found then it is highly unlikely that
' both sequences as generated, before pair directing, would
' be the same - more likely a manifest of repeat within the RNG
' (reason for adopting the 214013 / 2531011 RNG )
' I've added a final macro to do the crosschecking to produce a
' file of pairs original and directed
' As previously before running change 'jul08' to your date choice
' using Replace/All command, the long conditional statements
' have to be on one line, and change xxxx value to required
' number of profiles
Open "jul08 g" For Output As #1
' outputs directed and divided by first digit
Open "jul08 0" For Output As #10
Open "jul08 1" For Output As #11
Open "jul08 2" For Output As #12
Open "jul08 3" For Output As #13
Open "jul08 4" For Output As #14
Open "jul08 5" For Output As #15
Open "jul08 6" For Output As #16
Open "jul08 7" For Output As #17
Open "jul08 8" For Output As #18
Open "jul08 9" For Output As #19
' change xxxx for different total size
' for xxxx = 10000000 my computer took 5 hours to generate over-night
xxxx = 10000000
xxxb = xxxx / 10
xxxd = xxxx / 100
xxxx = xxxx - 1
' beep count on every 10th time division
' as a progress indicator
' xxxx needs to be more than 50000
For x = 0 To xxxx
If x / xxxb = Int(x / xxxb) And x <> 0 Then
For beepc = 1 To x / xxxb
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
' beep every 100th time division
If x / xxxd = Int(x / xxxd) And x <> 0 Then
Beep
End If
For j = 0 To 1
' vWA ,first locus
' RNG random number generator
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
If ph(j) < 0.001 Then ph(j) = 11
If ph(j) < 0.106 Then ph(j) = 1
If ph(j) < 0.186 Then ph(j) = 2
If ph(j) < 0.402 Then ph(j) = 3
If ph(j) < 0.672 Then ph(j) = 4
If ph(j) < 0.891 Then ph(j) = 5
If ph(j) < 0.984 Then ph(j) = 6
If ph(j) < 0.998 Then ph(j) = 7
If ph(j) < 1 Then ph(j) = 8
If ph(j) > 10 Then ph(j) = 0
Next j
For j = 2 To 3
' THO1
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
If ph(j) < 0.002 Then ph(j) = 11
If ph(j) < 0.243 Then ph(j) = 1
If ph(j) < 0.437 Then ph(j) = 2
If ph(j) < 0.545 Then ph(j) = 3
If ph(j) < 0.546 Then ph(j) = 4
If ph(j) < 0.686 Then ph(j) = 5
If ph(j) < 0.99 Then ph(j) = 6
If ph(j) < 1 Then ph(j) = 7
If ph(j) > 10 Then ph(j) = 0
Next j
For j = 4 To 5
' D8
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
If ph(j) < 0.018 Then ph(j) = 11
If ph(j) < 0.031 Then ph(j) = 1
If ph(j) < 0.125 Then ph(j) = 2
If ph(j) < 0.191 Then ph(j) = 3
If ph(j) < 0.334 Then ph(j) = 4
If ph(j) < 0.667 Then ph(j) = 5
If ph(j) < 0.876 Then ph(j) = 6
If ph(j) < 0.964 Then ph(j) = 7
If ph(j) < 0.995 Then ph(j) = 8
If ph(j) < 1 Then ph(j) = 9
If ph(j) > 10 Then ph(j) = 0
Next j
For j = 6 To 7
' FGA
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
pb(j) = "Z"
If ph(j) < 0.025 Then ph(j) = 11
If ph(j) < 0.081 Then ph(j) = 1
If ph(j) < 0.224 Then ph(j) = 2
If ph(j) < 0.226 And ph(j) >= 0.224 Then pb(j) = "A"
If ph(j) < 0.413 Then ph(j) = 3
If ph(j) < 0.415 And ph(j) >= 0.413 Then pb(j) = "B"
If ph(j) < 0.58 Then ph(j) = 4
If ph(j) < 0.591 And ph(j) >= 0.58 Then pb(j) = "C"
If ph(j) < 0.73 Then ph(j) = 5
If ph(j) < 0.734 And ph(j) >= 0.73 Then pb(j) = "D"
If ph(j) < 0.88 Then ph(j) = 6
If ph(j) < 0.882 And ph(j) >= 0.88 Then pb(j) = "E"
If ph(j) < 0.957 Then ph(j) = 7
If ph(j) < 0.992 Then ph(j) = 8
If ph(j) < 0.999 Then ph(j) = 9
If ph(j) < 1 And ph(j) >= 0.999 Then pb(j) = "F"
If ph(j) > 10 Then ph(j) = 0
If pb(j) <> "Z" Then ph(j) = pb(j)
Next j
For j = 8 To 9
' D21
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
pb(j) = "Z"
If ph(j) < 0.001 Then pb(j) = "A"
If ph(j) < 0.002 And ph(j) >= 0.001 Then pb(j) = "B"
If ph(j) < 0.033 Then ph(j) = 11
If ph(j) < 0.193 Then ph(j) = 1
If ph(j) < 0.419 Then ph(j) = 2
If ph(j) < 0.677 Then ph(j) = 3
If ph(j) < 0.704 Then ph(j) = 4
If ph(j) < 0.773 Then ph(j) = 5
If ph(j) < 0.866 Then ph(j) = 6
If ph(j) < 0.884 Then ph(j) = 7
If ph(j) < 0.974 Then ph(j) = 8
If ph(j) < 0.975 And ph(j) >= 0.974 Then pb(j) = "C"
If ph(j) < 0.997 Then ph(j) = 9
If ph(j) < 1 And ph(j) >= 0.997 Then pb(j) = "D"
If ph(j) > 10 Then ph(j) = 0
If pb(j) <> "Z" Then ph(j) = pb(j)
Next j
For j = 10 To 11
' D18
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
pb(j) = "Z"
If ph(j) < 0.001 Then pb(j) = "A"
If ph(j) < 0.009 And ph(j) >= 0.001 Then pb(j) = "B"
If ph(j) < 0.021 Then ph(j) = 11
If ph(j) < 0.16 Then ph(j) = 1
If ph(j) < 0.285 Then ph(j) = 2
If ph(j) < 0.449 Then ph(j) = 3
If ph(j) < 0.594 Then ph(j) = 4
If ph(j) < 0.731 Then ph(j) = 5
If ph(j) < 0.846 Then ph(j) = 6
If ph(j) < 0.926 Then ph(j) = 7
If ph(j) < 0.967 Then ph(j) = 8
If ph(j) < 0.982 Then ph(j) = 9
If ph(j) < 0.992 And ph(j) >= 0.982 Then pb(j) = "C"
If ph(j) < 0.997 And ph(j) >= 0.992 Then pb(j) = "D"
If ph(j) < 0.998 And ph(j) >= 0.997 Then pb(j) = "E"
If ph(j) < 1 And ph(j) >= 0.998 Then pb(j) = "F"
' allele 20 (C) reduced from .017 to .015 as allele
' frequencies summed to 1.002
If ph(j) > 10 Then ph(j) = 0
If pb(j) <> "Z" Then ph(j) = pb(j)
Next j
For j = 12 To 13
' D2S1338
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
pb(j) = "Z"
If ph(j) < 0.037 Then ph(j) = 11
If ph(j) < 0.222 Then ph(j) = 1
If ph(j) < 0.309 Then ph(j) = 2
If ph(j) < 0.419 Then ph(j) = 3
If ph(j) < 0.557 Then ph(j) = 4
If ph(j) < 0.589 Then ph(j) = 5
If ph(j) < 0.613 Then ph(j) = 6
If ph(j) < 0.725 Then ph(j) = 7
If ph(j) < 0.867 Then ph(j) = 8
If ph(j) < 0.978 Then ph(j) = 9
If ph(j) < 0.997 And ph(j) >= 0.978 Then pb(j) = "A"
If ph(j) < 1 And ph(j) >= 0.997 Then pb(j) = "B"
If ph(j) > 10 Then ph(j) = 0
If pb(j) <> "Z" Then ph(j) = pb(j)
Next j
For j = 14 To 15
' D16
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
If ph(j) < 0.019 Then ph(j) = 11
If ph(j) < 0.148 Then ph(j) = 1
If ph(j) < 0.202 Then ph(j) = 2
If ph(j) < 0.491 Then ph(j) = 3
If ph(j) < 0.779 Then ph(j) = 4
If ph(j) < 0.965 Then ph(j) = 5
If ph(j) < 0.994 Then ph(j) = 6
If ph(j) < 1 Then ph(j) = 7
If ph(j) > 10 Then ph(j) = 0
Next j
For j = 16 To 17
' D19
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
pb(j) = "Z"
If ph(j) < 0.087 Then ph(j) = 11
If ph(j) < 0.309 Then ph(j) = 1
If ph(j) < 0.322 Then ph(j) = 2
If ph(j) < 0.704 Then ph(j) = 3
If ph(j) < 0.719 Then ph(j) = 4
If ph(j) < 0.896 Then ph(j) = 5
If ph(j) < 0.934 Then ph(j) = 6
If ph(j) < 0.975 Then ph(j) = 7
If ph(j) < 0.992 Then ph(j) = 8
If ph(j) < 0.997 Then ph(j) = 9
If ph(j) < 0.999 And ph(j) >= 0.997 Then pb(j) = "A"
If ph(j) < 1 And ph(j) >= 0.999 Then pb(j) = "B"
If ph(j) > 10 Then ph(j) = 0
If pb(j) <> "Z" Then ph(j) = pb(j)
Next j
For j = 18 To 19
' D3
' RNG
temp = x0 * a + c
temp = temp / z
x1 = (temp - Fix(temp)) * z
x0 = x1
phj = x1 / z
ph(j) = phj
If ph(j) < 0.001 Then ph(j) = 11
If ph(j) < 0.007 Then ph(j) = 1
If ph(j) < 0.139 Then ph(j) = 2
If ph(j) < 0.404 Then ph(j) = 3
If ph(j) < 0.651 Then ph(j) = 4
If ph(j) < 0.846 Then ph(j) = 5
If ph(j) < 0.987 Then ph(j) = 6
If ph(j) < 1 Then ph(j) = 7
If ph(j) > 10 Then ph(j) = 0
Next j
' output the original generated file
Write #1, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
' Because in real DNA profiles without further info ,no one
' knows which allele in each pair came from the mother or father
' by convention they are written smaller ,larger (or equal).
' The following directs each pair
For j = 0 To 18 Step 2
If ph(j + 1) < ph(j) Then
jjj = ph(j)
ph(j) = ph(j + 1)
ph(j + 1) = jjj
End If
Next j
' put extra conditional statements here to reduce
' the number of files or just delete some of the following
'
' dividing on first column, file by file
If ph(0) = 0 Then
Write #10, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count0 = count0 + 1
End If
If ph(0) = 1 Then
Write #11, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count1 = count1 + 1
End If
If ph(0) = 2 Then
Write #12, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count2 = count2 + 1
End If
If ph(0) = 3 Then
Write #13, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count3 = count3 + 1
End If
If ph(0) = 4 Then
Write #14, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count4 = count4 + 1
End If
If ph(0) = 5 Then
Write #15, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count5 = count5 + 1
End If
If ph(0) = 6 Then
Write #16, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count6 = count6 + 1
End If
If ph(0) = 7 Then
Write #17, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count7 = count7 + 1
End If
If ph(0) = 8 Then
Write #18, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count8 = count8 + 1
End If
If ph(0) = 9 Then
Write #19, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
count9 = count9 + 1
End If
Next x
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Close #1
' count file for data to fix for - next loops in sucessive dividings
Open "jul08 c" For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Dividing 10 files into 10 by second digit
' producing 100 files
' first one '0' different because of leading zero problem
Dim ps As String
Dim ph(26)
For xx = 0 To 0
yyyy = xx
temp = "jul08" & Str(yyyy)
temp0 = "jul08" & Str(yyyy) & " 0"
temp1 = "jul08" & Str(yyyy) & " 1"
temp2 = "jul08" & Str(yyyy) & " 2"
temp3 = "jul08" & Str(yyyy) & " 3"
temp4 = "jul08" & Str(yyyy) & " 4"
temp5 = "jul08" & Str(yyyy) & " 5"
temp6 = "jul08" & Str(yyyy) & " 6"
temp7 = "jul08" & Str(yyyy) & " 7"
temp8 = "jul08" & Str(yyyy) & " 8"
temp9 = "jul08" & Str(yyyy) & " 9"
tempc = "jul08" & Str(yyyy) & " c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a2$ = Mid(ps, 2, 1)
ph(1) = Val(a2$)
If ph(1) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(1) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(1) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(1) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(1) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(1) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(1) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(1) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(1) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(1) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
' output counts
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
For xx = 1 To 9
yyyy = xx
' beep count on every tenth division
' as a progress indicator
For beepc = 1 To xx
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
temp = "jul08" & Str(yyyy)
temp0 = "jul08" & Str(yyyy) & "0"
temp1 = "jul08" & Str(yyyy) & "1"
temp2 = "jul08" & Str(yyyy) & "2"
temp3 = "jul08" & Str(yyyy) & "3"
temp4 = "jul08" & Str(yyyy) & "4"
temp5 = "jul08" & Str(yyyy) & "5"
temp6 = "jul08" & Str(yyyy) & "6"
temp7 = "jul08" & Str(yyyy) & "7"
temp8 = "jul08" & Str(yyyy) & "8"
temp9 = "jul08" & Str(yyyy) & "9"
tempc = "jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a2$ = Mid(ps, 2, 1)
ph(1) = Val(a2$)
If ph(1) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(1) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(1) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(1) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(1) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(1) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(1) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(1) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(1) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(1) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
' output counts
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Dividing 100 files into 10 by third digit
' producing <>700 files
Dim ph(26)
Dim ps As String
' first ten because of supressed leading 0
For xx = 0 To 9
yyyy = xx
temp = "jul08" & " 0" & Str(yyyy)
temp0 = "jul08" & " 0" & Str(yyyy) & " 0"
temp1 = "jul08" & " 0" & Str(yyyy) & " 1"
temp2 = "jul08" & " 0" & Str(yyyy) & " 2"
temp3 = "jul08" & " 0" & Str(yyyy) & " 3"
temp4 = "jul08" & " 0" & Str(yyyy) & " 4"
temp5 = "jul08" & " 0" & Str(yyyy) & " 5"
temp6 = "jul08" & " 0" & Str(yyyy) & " 6"
temp7 = "jul08" & " 0" & Str(yyyy) & " 7"
temp8 = "jul08" & " 0" & Str(yyyy) & " 8"
temp9 = "jul08" & " 0" & Str(yyyy) & " 9"
tempc = "jul08" & " 0" & Str(yyyy) & " c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 3, 1)
ph(2) = Val(a3$)
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
' 10 to 69 ignoring 7....... upwards
For xx = 10 To 69
yyyy = xx
' beep count on every 10th file division
' as a progress indicator
If xx / 10 = Int(xx / 10) And xx <> 0 Then
For beepc = 1 To xx / 10
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
temp = "jul08" & Str(yyyy)
temp0 = "jul08" & Str(yyyy) & "0"
temp1 = "jul08" & Str(yyyy) & "1"
temp2 = "jul08" & Str(yyyy) & "2"
temp3 = "jul08" & Str(yyyy) & "3"
temp4 = "jul08" & Str(yyyy) & "4"
temp5 = "jul08" & Str(yyyy) & "5"
temp6 = "jul08" & Str(yyyy) & "6"
temp7 = "jul08" & Str(yyyy) & "7"
temp8 = "jul08" & Str(yyyy) & "8"
temp9 = "jul08" & Str(yyyy) & "9"
tempc = "jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 3, 1)
ph(2) = Val(a3$)
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
' Dividing 1000 files into 10 by fourth digit
' producing <>6,000 files
' ignoring files starting 0....... & 7......... upwards
Dim ph(26)
Dim ps As String
'
For xx = 100 To 699
yyyy = xx
' beep count on every 10th file division
' as a progress indicator
If xx / 100 = Int(xx / 100) And xx <> 0 Then
For beepc = 1 To xx / 100
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
temp = "jul08" & Str(yyyy)
temp0 = "jul08" & Str(yyyy) & "0"
temp1 = "jul08" & Str(yyyy) & "1"
temp2 = "jul08" & Str(yyyy) & "2"
temp3 = "jul08" & Str(yyyy) & "3"
temp4 = "jul08" & Str(yyyy) & "4"
temp5 = "jul08" & Str(yyyy) & "5"
temp6 = "jul08" & Str(yyyy) & "6"
temp7 = "jul08" & Str(yyyy) & "7"
temp8 = "jul08" & Str(yyyy) & "8"
temp9 = "jul08" & Str(yyyy) & "9"
tempc = "jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 4, 1)
ph(2) = Val(a3$)
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Dividing by fifth digit
' producing <>6,000 files
' ignoring files starting less than 11........ and more than 70....
Dim ph(26)
Dim ps As String
' after this stage set the default directory by
' calling up 'Open' file and then closing
'change sub-directory(yyy) and start nn... file
' 11... ,22... etc
' initial files on'dna' and because of large no. of files subdivided files
' and 'c' files on subdirectory '-yyy', note minus sign
yyy = -3
xn=0
For xx = 3300 To 3699
yyyy = xx
if xn = 0 then xn = xx
If (xx - xn) / 100 = Int((xx - xn) / 100) And xx <> 0 Then
qb=(xx-xn)/100
For beepc = 1 To Int (xn/1000) +(qb-10*int(qb/10))
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
' beep count on every 100 file division
' as a progress indicator
temp = "c:\dna\jul08" & Str(yyyy)
temp0 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "0"
temp1 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "1"
temp2 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "2"
temp3 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "3"
temp4 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "4"
temp5 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "5"
temp6 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "6"
temp7 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "7"
temp8 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "8"
temp9 = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "9"
tempc = "c:\dna\" & str(yyy) & "\jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 5, 1)
ph(2) = Val(a3$)
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' finding all counts >15,000 in 'c' files
' setfor range 100c to 699c
Dim ph(20)
temp0 = "jul08" & " largest" & ".txt"
Open temp0 For Output As #2
For xx = 100 To 699
yyyy = xx
temp = "jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Input #1, ph(0), ph(1), ph(2), ph(3), ph(4), ph(5), ph(6), ph(7), ph(8), ph(9), ph(10), ph(11), ph(12), ph(13), ph(14), ph(15), ph(16), ph(17), ph(18), ph(19)
cm = 0
For yy = 0 To 18 Step 2
If ph(yy + 1) > 15000 Then
cm = ph(yy + 1)
cm0 = ph(yy)
Write #2, xx & cm0, cm
End If
Next yy
Close #1
Next xx
Close #2
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Deal with files with 1 or 0 lines by padding out
Dim ps As String
' select band of files to process xx =
For xx = 22000 To 26999
' beep on every 1000th file division
' as a progress indicator
If xx / 1000 = Int(xx / 1000) And xx <> 0 Then
Beep
End If
yyyy = xx
temp = "jul08" & Str(yyyy)
Open temp For Input As #1
Count = 0
Do Until (EOF(1) = True) Or Count = 2
Input #1, ps
Count = Count + 1
Loop
Close (1)
Close #1
If Count = 1 Then
Open temp For Output As #1
Write #1, ps
Write #1, "99999999999999999999999999"
Close #1
End If
If Count = 0 Then
Open temp For Output As #1
Write #1, "99999999999999999999999999"
Write #1, "99999999999999999999999999"
Close #1
End If
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' sort many files in one go
' progress indicator observable number in window header
xn = 0
For xx = 11000 To 16999
' change file number for those >15,000 entries
' in Word97 highligh blocks of numbers using
' Shift+Alt+Mouse click to cut/copy and paste
' whole blocks of numbers like 55165 to 46265 below
' from "largest" file block to block below
If xx = 55165 Then xx = xx + 1
If xx = 55265 Then xx = xx + 1
If xx = 56165 Then xx = xx + 1
If xx = 56265 Then xx = xx + 1
If (xx - xn) / 100 = Int((xx - xn) / 100) And xx <> 0 Then
For beepc = 1 To int(xx/100) - 10*int(xx/1000)
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
yyyy = xx
temp = "jul08" & Str(yyyy)
'Sort 1000 related files in one go
'
Documents.Open FileName:=temp, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
:=wdLanguageNone
ActiveDocument.Save
ActiveWindow.Close
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
'
' to reconcattenate 1000 files
' more than 4000 exceeds number of open files allowed
' if changing from 1000 then change
' name of tempt file name
' has file etension of .txt
' do <1000 and >=7000 sparately
Documents.Add Template:="", NewTemplate:=False
xn = 0
tempt = "jul08 11-13999" & ".txt"
For xx = 11000 To 13999
' beep on every 1000th file
' as a progress indicator
If xn = 0 Then xn = xx
If (xx - xn) / 1000 = Int((xx - xn) / 1000) And xx <> 0 Then
qb = (xx - xn) / 1000
For beepc = 1 To Int(xn / 10000) + (qb - 10 * Int(qb / 10))
For beept = 1 To 300000
beepu = 1 / beept
Next beept
Beep
Next beepc
End If
' 100beep
If xx / 100 = Int(xx / 100) And xx <> 0 Then
Beep
End If
yyyy = xx
temp = "jul08" & Str(yyyy)
Selection.InsertFile FileName:=temp, Range:="", ConfirmConversions _
:=False, Link:=False, Attachment:=False
Next xx
ActiveDocument.SaveAs FileName:=tempt, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' to remove "" and "99999999999999999999999999" from a file
Dim ps As String
yyyy = 5
temp1 = "jul08" & Str(yyyy) & ".txt"
temp2 = "jul08" & Str(yyyy) & ".nnn"
temp3 = "jul08" & Str(yyyy) & "C" & ".nnn"
Open temp1 For Input As #1
Open temp2 For Output As #2
Count = 0
Do Until (EOF(1) = True)
flag = 0
Input #1, ps
If ps = "" Then flag = 2
If ps = "99999999999999999999999999" Then flag = 1
If flag = 0 Then
Count = Count + 1
Write #2, ps
End If
Loop
Close (1)
Close #1
Close #2
Open temp3 For Output As #3
Write #3, " count = ", Count
Close #3
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' sort and reconcattenate 0.... and 7....,8....
' Routine for dividing and sorting "excluded"
' >15,000 files
' dividing on sixth digit, padding
' sorting , reconcattenation
Dim ph(26)
Dim ps As String
For xx = 55000 To 55699
yyy = Int(xx / 10000)
yyy = -yyy
' change file number for those >15,000 entries
flag = 0
If xx = 55165 Then flag = 1
If xx = 55265 Then flag = 1
If xx = 56165 Then flag = 1
If xx = 56265 Then flag = 1
If flag = 1 Then
yyyy = xx
temp = "jul08" & Str(yyyy)
' Dividing by sixth digit
temp = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "0"
temp1 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "1"
temp2 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "2"
temp3 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "3"
temp4 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "4"
temp5 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "5"
temp6 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "6"
temp7 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "7"
temp8 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "8"
temp9 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "9"
tempc = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 6, 1)
ph(2) = Val(a3$)
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
' Deal with files with 1 or 0 lines by padding out
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
Open temp0 For Input As #1
Count = 0
Do Until (EOF(1) = True) Or Count = 2
Input #1, ps
Count = Count + 1
Loop
Close (1)
Close #1
If Count = 1 Then
Open temp0 For Output As #1
Write #1, ps
Write #1, "99999999999999999999999999"
Close #1
End If
If Count = 0 Then
Open temp0 For Output As #1
Write #1, "99999999999999999999999999"
Write #1, "99999999999999999999999999"
Close #1
End If
Next xxx
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
'Sort 10 related files in one go
'
Documents.Open FileName:=temp0, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
:=wdLanguageNone
ActiveDocument.Save
ActiveWindow.Close
Next xxx
Beep
' to delete contents of xx file
tempt = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
' before deleting saved as ....old.txt
Documents.Open FileName:=tempt, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
ActiveDocument.SaveAs FileName:=tempt & "old.txt", FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
Documents.Open FileName:=tempt, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.WholeStory
Selection.Cut
ActiveDocument.Save
ActiveWindow.Close
'
' to reconcattenate 10 files
' back to original 5 digit file with no file extension
Documents.Add Template:="", NewTemplate:=False
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
Selection.InsertFile FileName:=temp0, Range:="", ConfirmConversions _
:=False, Link:=False, Attachment:=False
Next xxx
Selection.WholeStory
Selection.Copy
' saved as .....9.txt
ActiveDocument.SaveAs FileName:=temp0, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
Documents.Open FileName:=tempt, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
Selection.Paste
ActiveDocument.Save
ActiveWindow.Close
End If
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Routine for dividing and sorting "excluded"
' >15,000 files of 6 digit file numbers
' dividing on seventh digit, padding
' sorting , reconcattenation
Dim ph(26)
Dim ps As String
For xx = 452656 To 453000
yyy = Int(xx / 100000)
yyy = -yyy
' change file number for those >15,000 entries
flag = 0
If xx = 451645 Then flag = 1
If xx = 451655 Then flag = 1
If xx = 451656 Then flag = 1
If xx = 452655 Then flag = 1
If xx = 452656 Then flag = 1
If flag = 1 Then
yyyy = xx
temp = "jul08" & Str(yyyy)
' Dividing by seventh digit
temp = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "0"
temp1 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "1"
temp2 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "2"
temp3 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "3"
temp4 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "4"
temp5 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "5"
temp6 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "6"
temp7 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "7"
temp8 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "8"
temp9 = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "9"
tempc = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy) & "c"
Open temp For Input As #1
Open temp0 For Output As #10
Open temp1 For Output As #11
Open temp2 For Output As #12
Open temp3 For Output As #13
Open temp4 For Output As #14
Open temp5 For Output As #15
Open temp6 For Output As #16
Open temp7 For Output As #17
Open temp8 For Output As #18
Open temp9 For Output As #19
count0 = 0
count1 = 0
count2 = 0
count3 = 0
count4 = 0
count5 = 0
count6 = 0
count7 = 0
count8 = 0
count9 = 0
Do Until (EOF(1) = True)
Input #1, ps
a3$ = Mid(ps, 7, 1)
ph(2) = Val(a3$)
' implicit in the following A,B,C,D or E get
' lumped in with 0 as Val(letter) = 0
If ph(2) = 0 Then
Write #10, ps
count0 = count0 + 1
End If
If ph(2) = 1 Then
Write #11, ps
count1 = count1 + 1
End If
If ph(2) = 2 Then
Write #12, ps
count2 = count2 + 1
End If
If ph(2) = 3 Then
Write #13, ps
count3 = count3 + 1
End If
If ph(2) = 4 Then
Write #14, ps
count4 = count4 + 1
End If
If ph(2) = 5 Then
Write #15, ps
count5 = count5 + 1
End If
If ph(2) = 6 Then
Write #16, ps
count6 = count6 + 1
End If
If ph(2) = 7 Then
Write #17, ps
count7 = count7 + 1
End If
If ph(2) = 8 Then
Write #18, ps
count8 = count8 + 1
End If
If ph(2) = 9 Then
Write #19, ps
count9 = count9 + 1
End If
x = x + 1
Loop
Close (1)
Close #1
Close #10
Close #11
Close #12
Close #13
Close #14
Close #15
Close #16
Close #17
Close #18
Close #19
Open tempc For Output As #20
Write #20, 0, count0, 1, count1, 2, count2, 3, count3, 4, count4, 5, count5, 6, count6, 7, count7, 8, count8, 9, count9
Close #20
' Deal with files with 1 or 0 lines by padding out
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
Open temp0 For Input As #1
Count = 0
Do Until (EOF(1) = True) Or Count = 2
Input #1, ps
Count = Count + 1
Loop
Close (1)
Close #1
If Count = 1 Then
Open temp0 For Output As #1
Write #1, ps
Write #1, "99999999999999999999999999"
Close #1
End If
If Count = 0 Then
Open temp0 For Output As #1
Write #1, "99999999999999999999999999"
Write #1, "99999999999999999999999999"
Close #1
End If
Next xxx
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
'Sort 10 related files in one go
'
Documents.Open FileName:=temp0, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _
SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _
wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _
wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _
wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _
:=wdLanguageNone
ActiveDocument.Save
ActiveWindow.Close
Next xxx
Beep
' to delete contents of xx file
tempt = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
' file saved as ....old.txt before deleting
Documents.Open FileName:=tempt, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.WholeStory
Selection.Cut
ActiveDocument.Save
ActiveWindow.Close
'
' to reconcattenate 10 files
' back to original 5 digit file with no file extension
Documents.Add Template:="", NewTemplate:=False
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
Selection.InsertFile FileName:=temp0, Range:="", ConfirmConversions _
:=False, Link:=False, Attachment:=False
Next xxx
Selection.WholeStory
Selection.Copy
' saved as .....9.txt
ActiveDocument.SaveAs FileName:=temp0, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
Documents.Open FileName:=tempt, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
Selection.Paste
ActiveDocument.Save
ActiveWindow.Close
End If
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Sort, by hand, the remaining 5 digit unsorted files above
' the 6 digit ones then reconcattenate back to 5 digit
' reconcattenation
Dim ph(26)
Dim ps As String
For xx = 45160 To 45300
yyyy = xx
yyy = Int(xx / 10000)
yyy = -yyy
' change file number for those >15,000 entries
flag = 0
tempt = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
If xx = 45164 Then flag = 1
If xx = 45165 Then flag = 1
If xx = 45265 Then flag = 1
If flag = 1 Then
' to delete contents of xx file
tempt = "c:\dna\" & Str(yyy) & "\jul08" & Str(yyyy)
' filesaved as ....old.txt before deleting
Documents.Open FileName:=tempt, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
ActiveDocument.SaveAs FileName:=tempt & "old.txt", FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
Documents.Open FileName:=tempt, ConfirmConversions:=False, ReadOnly _
:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate _
:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="" _
, Format:=wdOpenFormatAuto
Selection.WholeStory
Selection.Cut
ActiveDocument.Save
ActiveWindow.Close
yyyy = xx
temp = "jul08" & Str(yyyy)
' to reconcattenate 10 files
' back to original 5 digit file with no file extension
Documents.Add Template:="", NewTemplate:=False
For xxx = 10 * yyyy To 10 * yyyy + 9
temp0 = "c:\dna\" & Str(yyy) & "\jul08" & Str(xxx)
Selection.InsertFile FileName:=temp0, Range:="", ConfirmConversions _
:=False, Link:=False, Attachment:=False
Next xxx
Selection.WholeStory
Selection.Copy
' saved as .....9.txt
ActiveDocument.SaveAs FileName:=temp0, FileFormat:=wdFormatText, _
LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
ActiveWindow.Close
Documents.Open FileName:=tempt, ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
WritePasswordTemplate:="", Format:=wdOpenFormatAuto
Selection.Paste
ActiveDocument.Save
ActiveWindow.Close
Beep
End If
Next xx
'End Beep
For beepc = 1 To 30
For beept = 1 To 100000
beepu = 1 / beept
Next beept
Beep
Next beepc
' Note if there are any null records "" in the final sorted
' file then they will be interpreted as matches
' Find matching pairs in 12 digits
' xxxx is count = ????
b$ = "0"
Count = 0
Dim ps As String
Open "jul08 10m.txt" For Input As #1
Open "jul08 10m_m12.txt" For Output As #2
' change the 12 in the #2 file name above and
' the Left function below to suit number of matches
Do Until (EOF(1) = True)
Input #1, ps
a$ = Left(ps, 12)
If a$ = b$ Then
Write #2, ps
Count = Count + 1
End If
b$ = a$
Loop
Close (1)
Write #2, "Count ", Count
Close #1
Close #2
Beep
' Find matching triples in 12 digits
' xxxx is count from the count files
b$ = "0"
c$ = "0"
Count = 0
Dim ps As String
Open "jul08 10m.txt" For Input As #1
Open "jul08 10m_trip12.txt" For Output As #2
' change the 12 in the #2 file name above and
' the Left function below to suit number of matches
Do Until (EOF(1) = True)
Input #1, ps
a$ = Left(ps, 12)
a2$ = ps
If a$ = c$ Then
Write #2, a2$, b2$, c2$
Count = Count + 1
End If
If a$ = b$ Then
c$ = b$
c2$ = b2$
End If
b$ = a$
b2$ = a2$
Loop
Close (1)
Write #2, "Count ", Count
Close #1
Close #2
Beep
' Find matching quadruples in 12 digits
b$ = "0"
c$ = "0"
Count = 0
Dim ps As String
Open "jul08 10m.txt" For Input As #1
Open "jul08 10m_quad12.txt" For Output As #2
' change the 12 in the #2 file name above and
' the Left function below to suit number of matches
Do Until (EOF(1) = True)
Input #1, ps
a$ = Left(ps, 12)
a2$ = ps
If a$ = d$ Then
Write #2, a2$, b2$, c2$, d2$
Count = Count + 1
End If
If a$ = e$ Then Count = Count - 1
If a$ = b$ Then
e$ = d$
e2$ = d2$
End If
If a$ = c$ Then
d$ = c$
d2$ = c2$
End If
If a$ = b$ Then
c$ = b$
c2$ = b2$
End If
b$ = a$
b2$ = a2$
Loop
Close (1)
Write #2, "Count ", Count
Close #1
Close #2
Beep
' Find matching quintuples in 12 digits
b$ = "0"
c$ = "0"
Count = 0
Dim ps As String
Open "jul08 10m.txt" For Input As #1
Open "jul08_10m_quin12.txt" For Output As #2
' change the 12 in the #2 file name above and
' the Left function below to suit number of matches
Do Until (EOF(1) = True)
Input #1, ps
a$ = Left(ps, 12)
a2$ = ps
If a$ = e$ Then
Write #2, a2$, b2$, c2$, d2$, e2$
Count = Count + 1
End If
If a$ = f$ Then Count = Count - 1
If a$ = b$ Then
f$ = e$
f2$ = e2$
End If
If a$ = d$ Then
e$ = d$
e2$ = d2$
End If
If a$ = c$ Then
d$ = c$
d2$ = c2$
End If
If a$ = b$ Then
c$ = b$
c2$ = b2$
End If
b$ = a$
b2$ = a2$
Loop
Close (1)
Write #2, "Count ", Count
Close #1
Close #2
Beep
' to check RNG this macro converts all
' original generated profiles to directed numbers line by line
' then use word97 Find to find each matched profile
Dim ph(20)
Dim ps As String
temp = "jul08 g"
Open temp For Input As #1
temp2 = "jul08 k"
Open temp2 For Output As #2
Do Until (EOF(1) = True)
Input #1, ps
a1$ = Mid(ps, 1, 1)
a2$ = Mid(ps, 2, 1)
a3$ = Mid(ps, 3, 1)
a4$ = Mid(ps, 4, 1)
a5$ = Mid(ps, 5, 1)
a6$ = Mid(ps, 6, 1)
a7$ = Mid(ps, 7, 1)
a8$ = Mid(ps, 8, 1)
a9$ = Mid(ps, 9, 1)
a10$ = Mid(ps, 10, 1)
a11$ = Mid(ps, 11, 1)
a12$ = Mid(ps, 12, 1)
a13$ = Mid(ps, 13, 1)
a14$ = Mid(ps, 14, 1)
a15$ = Mid(ps, 15, 1)
a16$ = Mid(ps, 16, 1)
a17$ = Mid(ps, 17, 1)
a18$ = Mid(ps, 18, 1)
a19$ = Mid(ps, 19, 1)
a20$ = Mid(ps, 20, 1)
ph(0) = a1$
ph(1) = a2$
ph(2) = a3$
ph(3) = a4$
ph(4) = a5$
ph(5) = a6$
ph(6) = a7$
ph(7) = a8$
ph(8) = a9$
ph(9) = a10$
ph(10) = a11$
ph(11) = a12$
ph(12) = a13$
ph(13) = a14$
ph(14) = a15$
ph(15) = a16$
ph(16) = a17$
ph(17) = a18$
ph(18) = a19$
ph(19) = a20$
For j = 0 To 18 Step 2
If ph(j + 1) < ph(j) Then
jjj = ph(j)
ph(j) = ph(j + 1)
ph(j + 1) = jjj
End If
Next j
Write #2, ps, ph(0) & ph(1) & ph(2) & ph(3) & ph(4) & ph(5) & ph(6) & ph(7) & ph(8) & ph(9) & ph(10) & ph(11) & ph(12) & ph(13) & ph(14) & ph(15) & ph(16) & ph(17) & ph(18) & ph(19)
Loop
Close (1)
Close #1
Close #2
Beep
Use the converter on dnas5.htm for converting alphanumeric
strings back to standard form 'profiles'
To delete all or some of these thousands of files
it is easier/quicker using Command Prompt
and good old DOS commands cd , cd\ , dir , del jul*.* etc
for permanently deleting rather than via Recycle bin
Results
8 10 loci matches
"25124557123517343325"
"34155735233414341355"
"35264534261434341526"
"45163512231737343335"
"45164523131417353356"
"45264846131529451333"
"45355634363519341334"
"45365523231348451334"
Converting to standard form
vWa,THO1,D8,FGA,D21,D18,D2,D16,D19,D3
(15,18)(6,7)(12,13)(23,25)(28,29)(14,16)(17,23)(11,12)(14,14)(14,17)
(16,17)(6,9)(13,15)(21,23)(29,30)(14,15)(17,20)(11,12)(13,14)(17,17)
(16,18)(7,9.3)(12,13)(21,22)(29,31.2)(12,15)(19,20)(11,12)(13,15)(14,18)
(17,18)(6,9.3)(11,13)(19,20)(29,30)(12,18)(19,23)(11,12)(14,14)(15,17)
(17,18)(6,9.3)(12,13)(20,21)(28,30)(12,15)(17,23)(11,13)(14,14)(17,18)
(17,18)(7,9.3)(12,16)(22,24)(28,30)(12,16)(18,25)(12,13)(13,14)(15,15)
(17,18)(8,9)(13,14)(21,22)(30,31.2)(14,16)(17,25)(11,12)(13,14)(15,16)
(17,18)(8,9.3)(13,13)(20,21)(29,30)(12,14)(20,24)(12,13)(13,14)(15,16)
Minimum Allele Frequencies in the above
vWA 15 8%
THO1 8 10.8%
D8 11 6.6
FGA 25 7.5%
D21 31.2 9.3%
D18 18 8%
D2 19 11%
D16 13 18.6%
D19 15 17.7%
D3 14 13.2%
Previous 10 loci matches from dnas.htm dnas5.htm files were
(15,16) (6,9.3) (13,13) (20,23) (29,30) (15,17) (20,25) (9,11) (14,15) (14,16)
(16,17) (7,8) (13,15) (20,24) (29,30) (13,17) (21,24) (12,12) (14,15) (17,17)
(16,17) (9.3,9.3) (13,14) (20,22) (30,30) (12,14) (17,23) (12,13) (13,14) (16,17)
(17,17) (7,9.3) (12,13) (20,23) (28,30) (15,16) (18,24) (12,12) (13,14) (14,14)
(17,18) (6,9.3) (10,13) (18,22) (28,31) (12,18) (17,20) (12,12) (13,14) (17,18)
(17,18) (6,9.3) (13,14) (20,23) (28,29) (13,14) (17,20) (11,12) (14,14) (15,17)
(17,18) (6,9.3) (14,15) (21,24) (29,30) (14,14) (17,24) (11,12) (13,14) (15,16)
(17,18) (8,9) (13,14) (20,22) (30,30) (14,15) (20,20) (12,13) (13,14) (16,18)
(17,18) (8,9.3) (13,14) (20,23) (28,30) (15,17) (17,24) (11,12) (13,14) (15,16)
(18,18) (6,9.3) (12,14) (20,21) (29,30) (13,14) (20,25) (11,13) (13,14) (15,17)
no repeats - so more evidence of a good Random Number Generator
So the "Average Joe" for all 18 , 10 loci matches so far is
vWa,THO1,D8,FGA,D21,D18,D2,D16,D19,D3
(17,18) (6,9.3) (12,13) (20,23) (29,30) (12,14) (17,20) (11,12) (13,14) (15,16)
RNG check for the latest 8 results
"25124557123517343325"
started as:
52124557215371343325 &
25124557213517343352
"34155735233414341355"
started as:
34157553234341341355 &
34517553323414431355
"35264534261434341526"
started as:
35265443621443345126 &
53625434264134431526
"45163512231737343335"
started as:
54615321321737433335 &
54165312321773433353
"45164523131417353356"
started as:
45614532314171533356 &
45165423314171353365
"45264846131529451333"
started as:
45628446131592453133 &
45264846315129541333
"45355634363519341334"
started as:
45355634635391343143 &
54535643363591343143
"45365523231348451334"
started as:
54635532321384453134 &
54365523321384543143
So RNG good on 200 million sequential calls
Number of matches on first 9 loci
And one of two on 10th loci was 64
So number of 19 datapoint matches
In 10 milion profiles would be
About 640 before any co-ancestry
factors are brought in.
9 loci pair matches 114
8 loci - 1,433
7 loci - 17,850
6 loci - 458,400
Triple matches
6 loci - 75,941
7 loci - 182
8 loci - 1
Quadruple matches
6 loci - 18,692
7 loci - 2
Quintuple matches
6 loci - 5,620
7 loci - 0
Some processing times for 10 million UK 10 loci
on an old pc.
Initial generation 4 hours 32 min
Second digit 'division' 19 min
Third digit division 20 min
Fourth digit division 30 min
5th digit division of ....3...... only , 9 minutes
Sorting 33... to 35,999 excluding the files
larger than 15,000 entries was 2 hours
Divide , sort, reconcattenate 41 exclusions
in 44... to 45999 subset , 30 min
Reconcattenate 22.... to 22699 back to 2..... , 1 hour
Removing padding from all files about 20 min
Single run for pair matches in 10million , 7 min
RNG check routine, pair directing all the
original undirected entries, 1 hour 30 min
