<p>这对我同时使用microsoftaccessvba和microsoftexcelvba都有效。这不是很有效的代码,但它是有效的。我可以在Access和Excel中打开结果文件。在</p>
<p>设置<code>sDBF*</code>和<code>sOutDBF*</code>变量,使其适合您自己的自定义路径。在</p>
<pre><code>Sub VBASolution()
Dim oRS
Dim sConn
Dim sDBFPath, sOutDBFPath
Dim sDBFName, sOutDBFName
Dim oDict
Dim curTID, curZone, sZones
Dim oConn
Dim oFS
Dim sTableName
sDBFPath = "C:\Path\To\DBFs\"
sDBFName = "Input.dbf"
sOutDBFPath = "C:\Path\To\DBFs\"
sOutDBFName = "RESULTS.dbf"
sConn = "Driver={Microsoft dBASE Driver (*.dbf)}; DriverID=277; Dbq="
Set oRS = CreateObject("ADODB.Recordset")
oRS.Open "SELECT DISTINCT tid, zone FROM " & sDBFName, sConn & sDBFPath
Set oDict = CreateObject("Scripting.Dictionary")
Do While Not oRS.EOF
curTID = oRS.Fields("tid").Value
curZone = oRS.Fields("zone").Value
If Not oDict.Exists(curTID) Then
oDict.Add curTID, CreateObject("Scripting.Dictionary")
End If
If Not oDict(curTID).Exists(curZone) Then
oDict(curTID).Add curZone, curZone
End If
oRS.MoveNext
Loop
oRS.Close
Set oRS = Nothing
Set oConn = CreateObject("ADODB.Connection")
oConn.Open sConn & sOutDBFPath
'Delete the resultant DBF file if it already exists.
Set oFS = CreateObject("Scripting.FileSystemObject")
With oFS
If .FileExists(sOutDBFPath & "\" & sOutDBFName) Then
.DeleteFile sOutDBFPath & "\" & sOutDBFName
End If
End With
sTableName = oFS.GetBaseName(sOutDBFName)
oConn.Execute "CREATE TABLE " & sTableName & " (tid int, zone varchar(80))"
Dim i, j
For Each i In oDict.Keys
curTID = i
sZones = ""
For Each j In oDict(i)
sZones = sZones & "," & j
Next
sZones = Mid(sZones, 2)
oConn.Execute "INSERT INTO " & sTableName & " (tid, zone) VALUES ('" & curTID & "','" & sZones & "')"
Next
oConn.Close
Set oConn = Nothing
Set oDict = Nothing
Set oFS = Nothing
End Sub
</code></pre>
<p>编辑:为了它的价值,我还把它插入到Windows XP中的VBScript.VBS文件(文本)中,并在文件底部添加以下行:</p>
<p><code>Call VBASolution()</code></p>
<p>我不知道它是否需要安装Office,或者Windows是否附带了相应的dbf驱动程序。在</p>