代码改变世界

Excel 导出指定行为txt文件（VBA,宏）

2014-04-12 18:06  小sa  阅读(4288)  评论(0)  编辑  收藏  举报

 

要从Excel 多个sheet内导出指定行为txt文件，懒得用C#了，写个VBA宏

  1 Sub Export()
  2     Dim FileName As Variant
  3     Dim Sep As String
  4     Dim StartSheet As Integer
  5     Dim EndSheet As Integer
  6     
  7     Dim ExportIndex As Integer
  8     
  9     '文件名
 10     FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
 11     If FileName = False Then
 12         ''''''''''''''''''''''''''
 13         ' user cancelled, get out
 14         ''''''''''''''''''''''''''
 15         Exit Sub
 16     End If
 17     '分隔符
 18    ' Sep = Application.InputBox("Enter a separator character.", Type:=2)
 19     
 20     '开始Sheet
 21     'StartSheet = Application.InputBox("开始Sheet.", Type:=2)
 22     '结束Sheet
 23     EndSheet = Application.InputBox("结束Sheet.", Type:=2)
 24     
 25     '导出行
 26     ExportIndex = Application.InputBox("导出行号.", Type:=2)
 27    
 32     ShartSheet:=StartSheet, EndSheet:=EndSheet, ExportRow:=ExportIndex
 33      ExportRangeToTextFile FName:=CStr(FileName), SelectionOnly:=False, AppendData:=False, _
 34     ShartSheet:=1, EndSheet:=EndSheet, ExportRow:=ExportIndex
 35 End Sub
 36 
 37 
 38 
 39 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 40 ' 将Excel内多个Sheet中的某一行导出Text
 41 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 42 Public Sub ExportRangeToTextFile(FName As String, _
 43     SelectionOnly As Boolean, _
 44     AppendData As Boolean, ShartSheet As Integer, _
 45     EndSheet As Integer, ExportRow As Integer)
 46 
 47 Dim WholeLine As String
 48 Dim FNum As Integer
 49 Dim RowNdx As Long
 50 Dim ColNdx As Integer
 51 Dim StartRow As Long
 52 Dim EndRow As Long
 53 Dim StartCol As Integer
 54 Dim EndCol As Integer
 55 Dim CellValue As String
 56 Dim X As Variant
 57 
 58 Application.ScreenUpdating = False
 59 On Error GoTo EndMacro:
 60 FNum = FreeFile
 61  Open FName For Output Access Write As #FNum
 62 
 63 For i = 1 To Application.sheets.Count
 64     X = Application.sheets(i).UsedRange.Value
 65     WholeLine = ""
 66    With Application.sheets(i).UsedRange
 67         StartRow = .Cells(1).Row
 68         StartCol = .Cells(1).Column
 69         EndRow = .Cells(.Cells.Count).Row
 70         EndCol = .Cells(.Cells.Count).Column
 71     End With
 72     
 73     For j = 1 To EndCol
 74         WholeLine = WholeLine + X(ExportRow, j) + Chr("9") '\t
 75     Next
 76     Print #FNum, WholeLine
 77 Next
 78     MsgBox "OK" '
 79 EndMacro:
 80 On Error GoTo 0
 81 Application.ScreenUpdating = True
 82 Close #FNum
 83 'XT = Application.Transpose(X)转置
 84 
 85 End Sub
 86 
 87 
 88 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 89 ' 导出单个sheet
 92 ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 93 Public Sub ExportSingleSheetToTextFile(FName As String, _
 94     Sep As String, SelectionOnly As Boolean, _
 95     AppendData As Boolean)
 96 
 97 Dim WholeLine As String
 98 Dim FNum As Integer
 99 Dim RowNdx As Long
100 Dim ColNdx As Integer
101 Dim StartRow As Long
102 Dim EndRow As Long
103 Dim StartCol As Integer
104 Dim EndCol As Integer
105 Dim CellValue As String
106 
107 
108 Application.ScreenUpdating = False
109 On Error GoTo EndMacro:
110 FNum = FreeFile
111 
112 If SelectionOnly = True Then
113     With Selection
114         StartRow = .Cells(1).Row
115         StartCol = .Cells(1).Column
116         EndRow = .Cells(.Cells.Count).Row
117         EndCol = .Cells(.Cells.Count).Column
118     End With
119 Else
120     With ActiveSheet.UsedRange
121         StartRow = .Cells(1).Row
122         StartCol = .Cells(1).Column
123         EndRow = .Cells(.Cells.Count).Row
124         EndCol = .Cells(.Cells.Count).Column
125     End With
126 End If
127 
128 If AppendData = True Then
129     Open FName For Append Access Write As #FNum
130 Else
131     Open FName For Output Access Write As #FNum
132 End If
133 
134 For RowNdx = StartRow To EndRow
135     WholeLine = ""
136     For ColNdx = StartCol To EndCol
137         If Cells(RowNdx, ColNdx).Value = "" Then
138             CellValue = Chr(34) & Chr(34)
139         Else
140            CellValue = Cells(RowNdx, ColNdx).Value
141         End If
142         WholeLine = WholeLine & CellValue & Sep
143     Next ColNdx
144     WholeLine = Left(WholeLine, Len(WholeLine) - Len(Sep))
145     Print #FNum, WholeLine
146 Next RowNdx
147 
148 EndMacro:
149 On Error GoTo 0
150 Application.ScreenUpdating = True
151 Close #FNum
152 
153 End Sub

 

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将Excel内多个Sheet中的某一行导出New Sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportRangeToNewSheet(FName As String, _
    SelectionOnly As Boolean, _
    AppendData As Boolean, ShartSheet As Integer, _
    EndSheet As Integer, ExportRow As Integer)
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 X As Variant
Dim Xsheet As Worksheet

Set Xsheet = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
Xsheet.Name = FName 'Format(Now(), "HHmmss")

Application.ScreenUpdating = False

Dim index As Integer
 index = 1
'For i = 1 To Application.Sheets.Count
For i = ShartSheet To EndSheet 'Application.Sheets.Count
   With Application.Sheets(i).UsedRange
        EndCol = .Cells(.Cells.Count).Column
    For j = 1 To EndCol
        Xsheet.Cells(j, 2 * index - 1).Value = .Cells(1, j).Text
        Xsheet.Cells(j, 2 * index).Value = .Cells(ExportRow, j).Text
    Next
    End With
    index = index + 1
Next
    MsgBox "导出OK，Sheet名" + FName '
'XT = Application.Transpose(X)转置

End Sub

 

 //从text文件导入Excel sheet里面

Sub OpenFile()

 Dim filter As String
    Dim fileToOpen
   
    filter = "All Files(*.*),*.*,Word Documents(*.do*),*.do*," & _
            "Text Files(*.txt),*.txt"
    fileToOpen = Application.GetOpenFilename(filter, 4, "请选择文件")
   
    If fileToOpen = False Then
        MsgBox "你没有选择文件", vbOKOnly, "提示"
    Else
    
     ' Workbooks.Open FileName:=fileToOpen
     '   MsgBox "你选择的文件是：" & fileToOpen, vbOKOnly, "提示"
       With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" + fileToOpen, Destination:=Range("$A$1") _
        )
        .Name = "Sample"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    End If
End Sub

　　

vba: Importing text file into excel sheet

http://blog.csdn.net/ldwtill/article/details/8571781

Using a QueryTable


Sub Sample()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\Sample.txt", Destination:=Range("$A$1") _
        )
        .Name = "Sample"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 437
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
End Sub
Open the text file in memory

Sub Sample()
    Dim MyData As String, strData() As String

    Open "C:\Sample.txt" For Binary As #1
    MyData = Space$(LOF(1))
    Get #1, , MyData
    Close #1
    strData() = Split(MyData, vbCrLf)
End Sub
Once you have the data in the array you can export it to the current sheet.

Using the method that you are already using

Sub Sample()
    Dim wbI As Workbook, wbO As Workbook
    Dim wsI As Worksheet

    Set wbI = ThisWorkbook
    Set wsI = wbI.Sheets("Sheet1") '<~~ Sheet where you want to import

    Set wbO = Workbooks.Open("C:\Sample.txt")

    wbO.Sheets(1).Cells.Copy wsI.Cells

    wbO.Close SaveChanges:=False
End Sub
FOLLOWUP

You can use the Application.GetOpenFilename to choose the relevant file. For example...

Sub Sample()
    Dim Ret

    Ret = Application.GetOpenFilename("Prn Files (*.prn), *.prn")

    If Ret <> False Then
        With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & Ret, Destination:=Range("$A$1"))

            '~~> Rest of the code

        End With
    End If
End Sub