要从Excel 多个sheet内导出指定行为txt文件

  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