Excel VBA 루프는 각 셀을 새 단어 문서로 복사합니다.

Question

인터넷에서 vba 스크립트를 받았으며이 기능을 사용하여 완성 된 Excel을 단어로 복사 할 수 있습니다. 하지만 열 D와 E 만 복사하려고합니다. 그리고 모든 행에 대해 새 문서를 복사하십시오. micrsoft 사무실의 버전은 또한 시각 기본, Microsoft Word 15, Microsoft Excel 15에서 올바른 참조를 추가했습니다. 누군가 나를 도와주세요.

코드는 다음과 같다 : 당신이해야하는 트릭을 수행

**Module1** 

    Public Sub ExportToTextFile(FName As String, _ 
    Sep As String, SelectionOnly As Boolean, _ 
    AppendData As Boolean) 

    Dim WholeLine As String 
    Dim FNum As Integer 
    Dim RowNdx As Long 
    Dim ColNdx As Integer 
    Dim StartRow As Long 
    Dim EndRow As Long 
    Dim StartCol As Integer 
    Dim EndCol As Integer 
    Dim CellValue As String 


    Application.ScreenUpdating = False 
    On Error GoTo EndMacro: 
    FNum = FreeFile 

    If SelectionOnly = True Then 
     With Selection 
      StartRow = .Cells(1).row 
      StartCol = .Cells(1).Column 
      EndRow = .Cells(.Cells.Count).row 
      EndCol = .Cells(.Cells.Count).Column 
     End With 
    Else 
     With ActiveSheet.UsedRange 
      StartRow = .Cells(1).row 
      StartCol = .Cells(1).Column 
      EndRow = .Cells(.Cells.Count).row 
      EndCol = .Cells(.Cells.Count).Column 
     End With 
    End If 

    If AppendData = True Then 
     Open FName For Append Access Write As #FNum 
    Else 
     Open FName For Output Access Write As #FNum 
    End If 

    For RowNdx = StartRow To EndRow 
     WholeLine = "" 
     For ColNdx = StartCol To EndCol 
      If Cells(RowNdx, ColNdx).Value = "" Then 
       CellValue = Chr(34) & Chr(34) 
      Else 
       CellValue = Cells(RowNdx, ColNdx).Value 
      End If 
      WholeLine = WholeLine & CellValue & Sep 
     Next ColNdx 
     WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) 
     Print #FNum, WholeLine 
    Next RowNdx 

    EndMacro: 
    On Error GoTo 0 
    Application.ScreenUpdating = True 
    Close #FNum 

    End Sub 

    **Module2** 
    Sub DoTheExport() 
    Dim FileName As Variant 
    Dim Sep As String 

    FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Word Document (*.doc),*.doc") 
    If FileName = False Then 
    Exit Sub 
    End If 

    Sep = Application.InputBox("Enter a separator character.", Type:=2) 
    If Sep = vbNullString Then 
    Exit Sub 
    End If 

    Debug.Print "FileName: " & FileName, "Separator: " & Sep 
    ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _ 
    SelectionOnly:=False, AppendData:=True 

    End Sub 

Answer 1

몇 가지 작은 변화에.

'' **Module1** 

    Public Sub ExportToTextFile(FName As String, _ 
    Sep As String, SelectionOnly As Boolean) ' , _ 
    ' AppendData As Boolean) 

Dim WholeLine As String 
Dim FNum As Integer 
Dim RowNdx As Long 
Dim ColNdx As Integer 
Dim StartRow As Long 
Dim EndRow As Long 
Dim StartCol As Integer 
Dim EndCol As Integer 
Dim CellValue As String 
Dim RowFName As String 

Application.ScreenUpdating = False 
On Error GoTo EndMacro: 

If SelectionOnly = True Then 
    With Intersect(Selection, ActiveSheet.UsedRange) '' added this to make it safe to select the whole column 
     StartRow = .Cells(1).Row 
     StartCol = .Cells(1).Column 
     EndRow = .Cells(.Cells.Count).Row 
     EndCol = .Cells(.Cells.Count).Column 
    End With 
Else 
    With ActiveSheet.UsedRange 
     StartRow = .Cells(1).Row 
     StartCol = .Cells(1).Column 
     EndRow = .Cells(.Cells.Count).Row 
     EndCol = .Cells(.Cells.Count).Column 
    End With 
End If 


For RowNdx = StartRow To EndRow 
'' find and replace the .doc in the file with the row and a .doc 
RowFName = Replace(FName, ".doc", RowNdx & ".doc") 
'' moved the open statment inside the loop 
FNum = FreeFile 
Open RowFName For Output Access Write As #FNum 


    WholeLine = "" 
    For ColNdx = StartCol To EndCol 
     If Cells(RowNdx, ColNdx).Value = "" Then 
      CellValue = Chr(34) & Chr(34) 
     Else 
      CellValue = Cells(RowNdx, ColNdx).Value 
     End If 
     WholeLine = WholeLine & CellValue & Sep 
    Next ColNdx 
    WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep)) 
    Print #FNum, WholeLine 
    ' moved the close statment to the end of the loop. 
    Close #FNum 
Next RowNdx 

EndMacro: 
On Error GoTo 0 
Application.ScreenUpdating = True 

End Sub 

'' **Module2** 
Sub DoTheExport() 
Dim FileName As Variant 
Dim Sep As String 

FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Word Document (*.doc),*.doc") 
If FileName = False Then 
Exit Sub 
End If 

Sep = Application.InputBox("Enter a separator character.", Type:=2) 
If Sep = vbNullString Then 
Exit Sub 
End If 

Debug.Print "FileName: " & FileName, "Separator: " & Sep 
ExportToTextFile FName:=CStr(FileName), Sep:=CStr(Sep), _ 
SelectionOnly:=True ' Changed Selection only to true to make it grab the range you have selected. ie columns D:E Also removed the append option since we are wanting to write each row to a file. 

End Sub