Question

我从互联网上获得了一个vba脚本，这可以很好地将完成excel复制到word。但我想只复制D栏和E栏。并为每一行新文件。 micrsoft办公室版本2013年还在visual basic，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

Excel VBA循环将每个单元格复制到新的word文档

1 个答案: