Sub Main

'I assume you call your dependent variable as "depend" (no quotation marks)

'I assume you independent vars named as "var00001 ... var00010 ... " (default for SPSS)

Const Nvar = 6 ' enter the number of independent variables (1-13 for the exemplar dataset)

Const DepRange ="1 2" 'Only for CVA: if you have 2 groups coded as 1 and 2 then write "1 2"

Dim CountOff()

Dim MaxOff()

Dim Ar()

Dim CombString As Variant

Dim SepChar As String, a As String, d As String, ds1 As String, ds2 As String

Dim NewComb As String, NewComb1 As String, Comp1 As String, LR As Boolean, LNTr As Boolean, ExternValid As Boolean, DoSizeCorrection As Boolean, SelectSet As String, Prt As Boolean, z As Integer

Dim NumOfComb As Long

Dim Dummy

Dim SubSet As Long

Dim SubSetMax As Long, SubSetMin As Long

Dim NumOfElements As Long

Dim Counter1 As Long

Dim Counter2 As Long

Dim Counter3 As Long, StartRange As Long, EndRange As Long, rng As String

Dim R As Variant

R = Array("", "01", "02", "03", "04", "05", "06", "07", "08", "09", 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50)

NumOfElements = Nvar

CombString = R

'****Define variables

LR=False ' enter False if you are running CVA, if logistic regression then True

SubSetMin = 1 'min number of variables in subsets (from 1 to Nvar)

SubSetMax = 6 'max number of variables in subsets (less or equal to Nvar)

LNTr = False ' do logarithmic (LN) transformation?

DoSizeCorrection = False 'enter True if you want Darroch and Mosimann (1985) size correction (MORPHOMETRIC DATA ONLY!), otherwise enter False

'*****Partitioning large samples

StartRange=1 '( from 1 to n) starts with specified number of samples (Work-around of large analyses SPSS problem)

EndRange=9000 'ends after specified number (Work-around of large analyses SPSS problem)

Prt=False ' true/false, enter true if you want to deploy the above two variables

Counter3=0

rng= SubSetMin & "-" & SubSetMax

If SubSetMin = SubSetMax Then rng = "" & SubSetMin

If Prt Then rng=rng & "_" & StartRange & "-" & EndRange

'*****Partitioning large samples end

'*** External validation

ExternValid=True 'True If you do external validation

SelectSet=vbCrLf & "/SELECT=val(0)" 'code for the analysis (CVA) subset (here 0); a variable (here val) defining the internal and external dataset must be created in your datamatrix

If LR Then SelectSet=vbCrLf & "/SELECT = val EQ 0" 'code for the analysis (LR) subset (here 0); a variable (here val) defining the internal and external dataset must be created in your datamatrix

If ExternValid=False Then SelectSet=""

'*** end External validation

ds1 = "DISCRIMINANT" & vbCrLf & "/GROUPS=depend(" & DepRange & ")" & vbCrLf & "/VARIABLES="

ds2 = SelectSet & vbCrLf & "/ANALYSIS All" & vbCrLf & "/PRIORS EQUAL" & vbCrLf & "/STATISTICS=CROSSVALID" & vbCrLf & "/CLASSIFY=NONMISSING POOLED ." & vbCrLf & "EXECUTE." & vbCrLf

oms = "OMSLOG FILE='log.txt' /FORMAT=TEXT." & vbCrLf & "oms" & vbCrLf & "/desination VIEWER = NO /TAG='suppressall'." & vbCrLf & "OMS /select tables" & vbCrLf & "/IF COMMANDS = ['Discriminant']" & vbCrLf & "SUBTYPES = ['Classification Results' 'Notes']" & vbCrLf & "/desination format = tabtext outfile = 'subsets" & rng & ".txt'."

SepChar = ","

If LR Then

ds1 = "LOGISTIC REGRESSION depend" & SelectSet & vbCrLf & "/METHOD = ENTER "

ds2 = vbCrLf & "/CLASSPLOT" & vbCrLf & "/PRINT = SUMMARY" & vbCrLf & "/CRITERIA = PIN(.05) POUT(.10) ITERATE(20) CUT(.5) ." & vbCrLf & "Execute." & vbCrLf

oms = "OMSLOG FILE='log.txt' /FORMAT=TEXT." & vbCrLf & "oms" & vbCrLf & "/desination VIEWER = NO /TAG='suppressall'." & vbCrLf & "OMS /select tables" & vbCrLf & "/IF COMMANDS = ['Logistic Regression']" & vbCrLf & "SUBTYPES = ['Classification Table' 'Notes']" & vbCrLf & "/desination format = tabtext outfile = 'LR_subsets" & rng & ".txt'."

SepChar = ","

End If

'*****************' write to syntax window

''Dim objSyntaxDoc As ISpssSyntaxDoc

''Dim strSynCmd As String

''Set objSyntaxDoc=objSpssApp.GetDesignatedSyntaxDoc

'****************

''objSyntaxDoc.Text = oms

objSpssApp.ExecuteCommands oms, True

'Debug.Print oms

'Stop

For i = SubSetMin To SubSetMax 'prints all subsets of given range of length

SubSet = i

NumOfComb = Comb(NumOfElements, SubSet)

ReDim CountOff(SubSet)

ReDim MaxOff(SubSet)

For Counter1 = 1 To SubSet

CountOff(Counter1) = Counter1

MaxOff(Counter1) = NumOfElements - SubSet + Counter1

Next Counter1

For Counter1 = 1 To NumOfComb

NewComb = "": NewComb1=""

ReDim Ar(SubSet)

For Counter2 = 1 To SubSet

s1=CombString(CountOff(Counter2)): NewComb = NewComb & s1 & SepChar: NewComb1= NewComb1 & "var000" & s1 & " * "

Ar(Counter2)= s1

Next Counter2

Counter3=Counter3+1

If Prt =False Or (Prt = True And Counter3>=StartRange And Counter3 <=EndRange) Then

Debug.Print Counter3

NewComb1=Left(NewComb1, Len(NewComb1) - 3) & nc1(SubSet,LNTr)

'Debug.Print "NewComb1: " & NewComb1

a="": d=""

lnt="":lnt2="."

If LNTr Then

lnt="LN(": lnt2=")."

End If

For z=1 To SubSet

If DoSizeCorrection=True Then a=a & vbCrLf & nc1a(SubSet,Ar(z),LNTr) & NewComb1

If DoSizeCorrection=False Then a = a & vbCrLf & "COMPUTE v" & Ar(z) & " = " & lnt & "var000" & Ar(z) & lnt2

d=d+ "v" & Ar(z) & " "

Next z

a= a & vbCrLf & "EXECUTE." & vbCrLf

a= a & ds1 & d & ds2

'Debug.Clear

'Debug.Print a

'Stop

''objSyntaxDoc.Text = objSyntaxDoc.Text & a

objSpssApp.ExecuteCommands a, True

End If

CountOff(SubSet) = CountOff(SubSet) + 1

Dummy = SubSet

While Dummy > 1

If CountOff(Dummy) > MaxOff(Dummy) Then

CountOff(Dummy - 1) = CountOff(Dummy - 1) + 1

For Counter2 = Dummy To SubSet

CountOff(Counter2) = CountOff(Counter2 - 1) + 1

Next Counter2

End If

Dummy = Dummy - 1

Wend

Next Counter1

Next i ' end prints all subsets of given length

objSpssApp.ExecuteCommands vbCrLf & "omsend.",True

''objSyntaxDoc.Text = objSyntaxDoc.Text & vbCrLf & "omsend."

If Prt Then

Dim EndRangeReal As Long, dn As String

If Counter3 > EndRange Then EndRangeReal = EndRange: dn = "Next suggested StartRange is " & EndRangeReal+1

If Counter3 <= EndRange Then EndRangeReal = Counter3: dn = "Current subset is done"

MsgBox "Output includes samples: " & StartRange & "-" & EndRangeReal & vbCrLf & dn

End If

Beep

End Sub

Sub test

MsgBox Comb(5, 2)

'MsgBox FactorialCalc(1)

End Sub

Function Comb(N, k)

'N must be >=1, k must be <=1 and <= N

If N = k Then

Comb = 1

Else

Comb = FactorialCalc(N) / (FactorialCalc(k) * FactorialCalc(N - k))

End If

End Function

Function FactorialCalc(N)

Factorial = 1

For i = 1 To N

Factorial = Factorial * i

Next i

FactorialCalc = Factorial

End Function

Function nc1(SubSet,LNTr)

lnt=""

If LNTr Then

lnt=")"

End If

If SubSet > 1 Then

nc1 = ") ** (1/" & SubSet & "))" & lnt & "."

Else

nc1 = lnt & "."

End If

'Debug.Print "nc1:" & nc1

End Function

Function nc1a(SubSet,v,LNTr)

lnt=""

If LNTr Then

lnt="LN("

End If

If SubSet > 1 Then

nc1a = "COMPUTE v" & v & " = " & lnt & "var000" & v & "/(("

Else

nc1a="COMPUTE v" & v & " = " & lnt

End If

'Debug.Print "nc1a:" & nc1a

End Function