Excel 導出指定行為txt文件（VBA,宏）
2014-04-12 18:06 小sa 閱讀(4473) 評論(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
浙公網安備 33010602011771號