Question

我有一张excel表格，其中A列我有整数值我不知道我有多少价值观我不知道每个值之间是否有空格。
有些值有重复。

    A
--------
1| 76
2| 56
3| 34
4| ----
5| 9
6| 9
.| ---
.| ---
.| 56

我需要在文件.txt上写下没有重复项的所有值。

我如何在VBA中编码？

Answer 1

这样的事可以让你到那儿。

在您的VBA IDE中，转到工具菜单并选择参考。选择＆＃34; Microstoft ActiveX数据对象2.8 Library＆＃34;对于ADODB记录集。

在您的VBA IDE中，转到工具菜单并选择参考。选择＆＃34; Microsoft脚本运行时＆＃34;为您的文件输出。

Private Sub CommandButton1_Click()

    Dim rs As New ADODB.Recordset
    Dim ws As Excel.Worksheet
    Set ws = ActiveWorkbook.Sheets("Sheet1")
    Dim lastRow As Long
    Dim lRow As Long
    Dim ts As TextStream
    Dim fs As FileSystemObject

    'Create the text file to write to
    Set fs = New FileSystemObject
    Set ts = fs.CreateTextFile("C:\Temp\test.txt", True, False)

    'Add fields to your recordset for storing data.
    With rs
        .Fields.Append "Value", adChar, 25
        .Open
    End With

    'This is getting the last used row in column A
    lastRow = ws.Cells(ws.Rows.count, "A").End(xlUp).Row

    'Loop through the rows
    lRow = 1
    Do While lRow <= lastRow

        'Check if this is already data that we are counting
        rs.Filter = ""
        rs.Filter = "Value='" & ws.Range("A" & lRow).Value & "'"

        If rs.RecordCount = 0 Then
            'If this is a new value, add a new row for it
            rs.AddNew
            rs.Fields("Value").Value = ws.Range("A" & lRow).Value
            rs.Fields("Count").Value = 1
            rs.Update
        End If

    lRow = lRow + 1
    Loop

    'Remove the filer and move to the first record in the rs
    rs.Filter = ""
    rs.MoveFirst

    'Loop through the data we found and write it out
    Do While rs.EOF = False
        ts.WriteLine ws.Cells(rs.Fields("Value").Value)
    rs.MoveNext
    Loop

    'Clean up
    ts.Close: Set ts = Nothing
    Set fs = Nothing

End Sub

Answer 2

以下示例使用Dictionary获取不同的值，使用Join()生成结果文本，使用FileSystemObject将文本保存到文件中：

Sub WriteDistinctToFile()

    Dim rngSource As Range
    Dim varItem As Variant
    Dim arrDistinct() As Variant

    With ActiveWorkbook.Sheets("Sheet1")
        Set rngSource = Intersect(.UsedRange, .Columns(1)) ' only used cells in first column
    End With
    With CreateObject("Scripting.Dictionary")
        .Item("") = "" ' add empty key to remove it later
        For Each varItem In rngSource.Value
            .Item(varItem) = "" ' add each cell value to unique keys
        Next
        .Remove "" ' remove empty value
        arrDistinct = .Keys() ' convert to array
    End With
    With CreateObject("Scripting.FileSystemObject").OpenTextFile("C:\Test.txt", 2, True, 0) ' open text file for output in ASCII
        .Write Join(arrDistinct, vbCrLf) ' join values from array into new line separated string, then write to file
        .Close
    End With

End Sub

我如何迭代特定列？

2 个答案: