0

プロンプトを使用して手動で入力された B 列の 2 つのエントリの間にある行の範囲をエクスポートしようとしています。たとえば、プロンプトで 1 番目と 2 番目の検索語を尋ねられ、cat と入力してから dog と入力します。B5 には cat という単語があり、B50 には dog という単語があります。行 6 から 49 をキャプチャし、それを下にあるものに渡し、出力をテキスト ファイルに送信したいと考えています。

Sub ExportColumnsABToText()

Dim oStream As Object
Dim sTextPath As Variant
Dim sText As String
Dim sText2 As String
Dim sLine As String
Dim sType As String
Dim rIndex As Long, cIndex As Long

sTextPath = Application.GetSaveAsFilename("export.txt", "Text Files, *.txt")
If sTextPath = False Then Exit Sub

sText = ""

For rIndex = 4 To 700
    sLine = ""
    sType = Sheets![worksheet1].Cells(rIndex, 8).Text

            If sType = "A" Or sType = "CNAME" Then
        For cIndex = 1 To 2
            If cIndex > 1 Then
                sLine = sLine & vbTab
            End If
                sLine = sLine & Sheets![worksheet1].Cells(rIndex, cIndex).Text
        Next cIndex
        If Not Len(Trim(Replace(sLine, vbTab, ""))) = 0 Then
            If rIndex > 4 Then
                sText = sText & IIf(sText = "", "", vbNewLine) & sLine
            End If
        End If
    End If
    ' End If

Next rIndex


Set oStream = CreateObject("ADODB.Stream")
With oStream
  .Type = 2
  .Charset = "UTF-8"
  .Open
  .WriteText sText
  .SaveToFile sTextPath, 2
  .Close
End With

Set oStream = Nothing

End Sub

4

1 に答える 1

1

以下のコードを試してください

Sub ExportColumnsABToText()


    Dim rngFind As Range, rngStart As Range, rngEnd As Range, rngPrint As Range, cell As Range
    Dim Criteria1, Criteria2
    Dim sTextPath

    sTextPath = Application.GetSaveAsFilename("export.txt", "Text Files, *.txt")
    If sTextPath = False Then Exit Sub

    Set rngFind = Columns("B")

    Criteria1 = InputBox("Enter first criteria")
    Criteria2 = InputBox("Enter Second criteria")

    If Criteria1 = "" Or Criteria2 = "" Then
        MsgBox "Please enter both criteria"
        Exit Sub
    End If

    Set rngStart = rngFind.Find(What:=Criteria1, LookIn:=xlValues)
    Set rngEnd = rngFind.Find(What:=Criteria2, LookIn:=xlValues)

    If rngStart Is Nothing Then
        MsgBox "Criteria1 not found"
        Exit Sub
    ElseIf rngEnd Is Nothing Then
        MsgBox "Criteria2 not found"
        Exit Sub
    End If


    Dim FileNum As Integer
    Dim str_text As String
    Dim i As Integer, j As Integer

    FileNum = FreeFile

    For i = (rngStart.Row + 1) To (rngEnd.Row - 1)
        For j = 1 To 26
            str_text = str_text & " " & Cells(i, j)
        Next

        Open sTextPath For Append As #FileNum    ' creates the file if it doesn't exist
        Print #FileNum, str_text    ' write information at the end of the text file
        Close #FileNum
        str_text = ""
    Next

End Sub
于 2013-11-01T05:21:05.287 に答える