2017-12-30 44 views
-3

Ich habe ein VBA-Skript aus dem Internet und das funktioniert gut für das Kopieren der Compleet Excel zu Wort. Aber ich möchte nur die Spalte D und E kopieren. Und für jede Zeile ein neues Dokument. Die Version von Microsoft Office ist 2013 auch die richtigen Referenzen in Visual Basic, Microsoft Word 15, Microsoft Excel 15. Kann mir bitte jemand helfen.Excel VBA-Schleife kopieren Sie jede Zelle in ein neues Word-Dokument

Der Code ist wie folgt:

**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 
+0

Der Code, den Sie anzeigen, hat nichts mit dem Kopieren von Daten aus Excel in Word zu tun. Es schreibt einfach eine Textdatei mit Trennzeichen. Bitte erläutern Sie, was Sie zu tun versuchen. – YowE3K

Antwort

0

Ein paar kleine Änderungen an, was Sie haben den Trick.

'' **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 
+0

Dies erstellt immer noch eine Textdatei, keine Word-Datei. – YowE3K

+0

Das stimmt, dass es keine echte Word-Datei macht. Aber aus seiner Beschreibung ergab sich, dass nur eine Textdatei erstellt werden musste. "Dies funktioniert gut für das Kopieren der Compleet Excel zu Wort" – Jaragoth

+0

Danke, das funktioniert !! ist es auch möglich, auf eine Schleife zu setzen und den Namen des Dokuments zu speichern, wie in der Zelle B angegeben. Frohes neues Jahr :) –

Verwandte Themen