vba excelマクロを使用して作成した余分な空のテキストファイルを削除するにはファイル名がシート内のセルですか？

Question

私はexcel vbaマクロを使ったばかりです。私は、テキストファイルを作成し、個々のテキストファイルの名前としてセルの値を使用しようとしています。最初の値には文字が含まれており、それらの文字は置き換えられます。唯一の値はすべての数字です。その機能はうまくいきます。私の問題は、私が作成ボタンを実行すると、プログラムは名前が空のセルのベースであり、テキストファイルに入力として "D"が入力されていない余分なテキストファイルを作成します。私が望むのは、余分なテキストファイルを作成せずにテキストファイルを作成することです。以下は私のExcel形式とコードです。余分なテキストファイルで

 
abc-5687.req 
abc-5689.req 
abc-5690.req 
abc-5692.req 

結果として間違っ下記参照考えてみます：

abc-.req <-- extra text file created 
abc-5687.req 
abc-5689.req 
abc-5690.req 
abc-5692.req 

を

 
LOG DATA INPUT BLOCK NAME 
5687 D ASD 
5689 D 
5690 D 
5692 D 
5691 D 
5688 D 
4635 D 

正しい結果は、4つのテキストファイルを作成します。

は、私は以下のように3列の使用を持っています

マイコード：

Private Sub CREATE_REQ_Click() 
    Dim myDataSheet As Worksheet 
    Dim myReplaceSheet As Worksheet 
    Dim myLastRow As Long 
    Dim myRow As Long 
    Dim myFind As String 
    Dim myReplace1 As String 
    Dim myReplace2 As String 
    Dim sExportFolder, sFN 
    Dim rArticleName As Range 
    Dim rDisclaimer As Range 
    Dim oSh As Worksheet 
    Dim oFS As Object 
    Dim oTxt As Object 

' Specify name of Data sheet 
    Set myDataSheet = Sheets("Sheet1") 

' Specify name of Sheet with list of replacements 
    Set myReplaceSheet = Sheets("Sheet2") 

' Assuming list of replacement start in column A on row 2, find last entry in list 
    myLastRow = myReplaceSheet.Cells(Rows.Count, "A").End(xlUp).Row 

    Application.ScreenUpdating = False 

' Loop through all list of replacments 
    For myRow = 2 To myLastRow 
'  Get find and replace values (from columns A and B) 
     myFind = myReplaceSheet.Cells(myRow, "A") 
     myReplace1 = myReplaceSheet.Cells(myRow, "B") 
'  Start at top of data sheet and do replacements 
     myDataSheet.Activate 
     Range("A2").Select 
'  Ignore errors that result from finding no matches 
     On Error Resume Next 
'  Do all replacements on column A of data sheet 
     Columns("A:A").Replace What:=myFind, Replacement:=myReplace1, LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False 
    Next myRow 

    sExportFolder = "D:\TEST\REQ_FILES_CREATED_HERE" 
    Set oSh = Sheet1 
    Set oFS = CreateObject("Scripting.Filesystemobject") 

    For Each rArticleName In oSh.UsedRange.Columns("A").Cells 
     Set rDisclaimer = rArticleName.Offset(, 1) 
     If rArticleName = "" & "LOG DATA" Then 
      oTxt = False 
     Else 
      'Add .txt to the article name as a file name 
      sFN = "-" & rArticleName.Value & ".req" 
      Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True) 

      oTxt.Write rDisclaimer.Value 
      oTxt.Close 
     End If 
    Next 

    'Reset error checking 
    On Error GoTo 0 
    Application.ScreenUpdating = True 

    MsgBox "Replacements complete! " 
End Sub 

Answer 1

For Each rArticleName In oSh.UsedRange.Columns("A").Cells 
    Set rDisclaimer = rArticleName.Offset(, 1) 
    If Not(rArticleName = "" Or rArticleName = "LOG DATA") Then 
     'Add .txt to the article name as a file name 
     sFN = "-" & rArticleName.Value & ".req" 
     Set oTxt = oFS.OpenTextFile(sExportFolder & "\" & ActiveSheet.Cells(2, 3) & sFN, 2, True) 
     oTxt.Write rDisclaimer.Value 
     oTxt.Close 
    End If 
Next 

一行修正にかなり近い。あなたはIfを修正する必要があります。一度それが正しいとすると、Elseは必要ありません。