CottLi
4/22/2020 - 11:12 AM
UsefulVBAProgram
- 文件名批量获取和修改
' 函数本身只是创建了文件信息的表头和提取出当前文件所在目录的地址
Sub 批量获取文件名()
Cells = "" ' 清空所有单元格
Dim sfso 'Scripting.FileSystemObject，首字母即 sfso
Dim myPath As String ' 定义字符串变量用于存储文件路径
Dim sh As Object ' 定义shell对象变量
Dim Folder As Object ' 文件夹对象
Application.ScreenUpdating = False ' 关闭屏幕更新，提高运行速度
On Error Resume Next ' 如果发生错误，继续往下执行
' 创建文件系统对象
Set sfso = CreateObject("Scripting.FileSystemObject")
' 创建shell对象并赋值给变量 sh
Set sh = CreateObject("shell.application")
' 通过shell打开文件浏览器窗口，交互地选择文件夹
Set Folder = sh.BrowseForFolder(0, "", 0, "")
' 如果文件夹不为空文件夹，则获取文件夹的路径。这个路径是当前Excel文件所在的文件夹路径
If Not Folder Is Nothing Then
myPath = Folder.Items.Item.Path
End If
' 重启屏幕更新，恢复 Excel默认设置
Application.ScreenUpdating = True
' 定义存储信息的表头
Cells(1, 1) = "旧版名称" ' 文件的原名，如 myfile.doc
Cells(1, 2) = "文件类型" ' 为“文件”和“文件夹”之一
Cells(1, 3) = "所在位置" ' 文件路径，如 E:\datafoldeer
Cells(1, 4) = "新版名称" ' 为文件新取一个名字，如取名 MyNewFIle.doc 。 务必带上扩展名
' 调用核心函数提取目录 mypath 目录下的文件
Call 直接提取文件名(myPath & "\")
End Sub
' 此函数才是提取文件名的关键函数
Sub 直接提取文件名(myPath As String)
Dim i As Long ' 循环变量，遍历每一个行
Dim myTxt As String '
i = Range("A1048576").End(xlUp).Row ' 最下面有内容的行的行号
myTxt = Dir(myPath, 31) ' 使用 Dir函数 遍历当前目录下的 文件和文件夹
Do While myTxt <> "" ' 当 Dir 返回空字符串，即遍历结束时结束循环
' 如果需要错误继续往下执行(若继续遇到错误则依然继续往下执行)
On Error Resume Next
' 使用If条件语句跳过Excel文件自身、表示当前目录的 . 符号、表示当前目录子目录的 .. 符号和 "081226"
If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then
i = i + 1 ' 行号自增 1
Cells(i, 1) = "'" & myTxt ' 在文件名前拼接上单引号 '，作用呢？
' 判断路径是文件夹路径还是文件路径，并保存路径的类别信息（可以不要）
If (GetAttr(myPath & myTxt) And vbDirectory) = vbDirectory Then
Cells(i, 2) = "文件夹" ' 如果是文件夹，则在类别一栏填写“文件夹“
Else
Cells(i, 2) = "文件" ' 如果是文件，则在类别一栏填写”文件“
End If
' 注意：作为函数参数的 myPath 最后面的文件分隔符是带上了的；如 D:\datafoler\
' 下一行的代码是删除这个文件分隔符，方便和其他文件名拼接在一起，处理后为 D:\datafolder
Cells(i, 3) = Left(myPath, Len(myPath) - 1)
End If
myTxt = Dir ' 遍历下一个文件
Loop
End Sub
' 根据表格中存储的文件目录和新/旧文件名重命名文件，核心函数为 Name
Sub 批量重命名()
Dim OldFileName As String ' 定义存储旧文件名的变量
Dim NewFileName As String ' 定义存储新文件名的变量
For i = 2 To Range("A1048576").End(xlUp).Row
OldFileName = Cells(i, 3) & "\" & Cells(i, 1) ' 由文件夹路径拼接上旧文件名定位文件
NewFileName = Cells(i, 3) & "\" & Cells(i, 4) ' 有文件夹路径拼接上新文件名重命名文件
On Error Resume Next ' 如果发生错误继续往下执行，避免程序报错中断
Name OldFileName As NewFileName ' 核心代码：Name函数 重命名文件
Next
End Sub' 变量命名
Dim shtCount As Integer ' 工作表计数
Dim rng As Range ' Range变量定义
' Do ... While 开头判断式
Do [While 循环条件]
<循环体>
[Exit Do] ' 可用Exit Do中途退出循环
<循环体>
Loop
' Do ... While 结尾判断式
Do
<循环体>
[Exit Do]
<循环体>
Loop [While 循环条件]
' Do ... Until 结构
Do Until iCount>3 <循环体> Loop
Do <循环体> Loop Until iCount>3
' 基于条件强制退出Do循环
Do <循环体> If iCount>3 Exit Do <循环体> Loop
' 参数传递：值传递和参数传递
Sub ShtAdd(shtCount As Integer, ByVal shtDelete As Integer)
Worksheets.Add Count:=nCount ' 通过参数指定新建的工作表数量
' 判断A1单元格的底纹是不是黄色
If Range("A1").Interior.Color = RGB(255,255,0) Then ... End If
' 多行代码合并成一行，用冒号分隔。
Dim a%, b%, c% : a = 1 : b = 2 : c = 3 ' 百分号相当于 As Integer
' 清空单元格内容
Cells.ClearContents
' 工作簿信息
Range("B2") = ThisWorkbook.Name ' 文件名，带扩展名那种，如 myfile.doc
Range("B3") = ThisWorkbook.Path ' 文件路径
Range("B4") = ThisWorkbook.FullName ' 路径+文件名
' 获取工作表已使用区域以及其行数和和列数
Dim arr()
arr = Sheet1.UsedRange '将工作表的内容放入arr数组中
myRow = UBound(arr, 1) '计算出数组的行数
myCol = UBound(arr, 2) '计算出数组的列数
‘ 自编文件批量命名VBA
Sub FileReNameInBatch()
Dim sfso 'Scripting.FileSystemObject，首字母即 sfso
Dim myPath As String ' 定义字符串变量用于存储文件路径
Dim sh As Object ' 定义shell对象变量
Dim Folder As Object ' 文件夹对象
Application.ScreenUpdating = False ' 关闭屏幕更新，提高运行速度
On Error Resume Next ' 如果发生错误，继续往下执行
' 创建文件系统对象
Set sfso = CreateObject("Scripting.FileSystemObject")
' 创建shell对象并赋值给变量 sh
Set sh = CreateObject("shell.application")
Set Folder = sh.BrowseForFolder(0, "", 0, "")
' 如果文件夹不为空文件夹，则获取文件夹的路径。这个路径是当前Excel文件所在的文件夹路径
If Not Folder Is Nothing Then
myPath = Folder.Items.Item.Path
End If
' 重启屏幕更新，恢复 Excel默认设置
Application.ScreenUpdating = True
' 正式开始获取重命名文件
Dim myTxt As String '
myTxt = Dir(myPath & "\", 31) ' 使用 Dir函数 遍历当前目录下的 文件和文件夹
Dim OldFileName As String ' 定义存储旧文件名的变量
Dim NewFileName As String ' 定义存储新文件名的变量
' Dim strArr() As String
Do While myTxt <> "" ' 当 Dir 返回空字符串，即遍历结束时结束循环
' 如果需要错误继续往下执行(若继续遇到错误则依然继续往下执行)
On Error Resume Next
' 使用If条件语句跳过Excel文件自身、表示当前目录的 . 符号、表示当前目录子目录的 .. 符号和 "081226"
If myTxt <> ThisWorkbook.Name And myTxt <> "." And myTxt <> ".." And myTxt <> "081226" Then
strArr = Split(myTxt, ".")
OldFileName = strArr(0)
strExt = strArr(UBound(strArr))
NewFileName = Cells(2, 1) & OldFileName & Cells(2, 2) & "." & strExt
OldFileName = myPath & "\" & OldFileName & "." & strExt
NewFileName = myPath & "\" & NewFileName
Name OldFileName As NewFileName ' 核心代码：Name函数 重命名文件
End If
myTxt = Dir ' 遍历下一个文件
Loop
End SubSub Excel2bib()
Dim rg As Range
Set rg = ActiveSheet.UsedRange
Dim iRow As Integer, iRowCount As Integer
Dim iCol As Integer, iColCount As Integer
iRow = rg.Rows.Count
iCol = rg.Columns.Count
Dim strArr As Variant '定义一个Variant类型的变量，名称为arr
strArr = rg.Value '将A1:C3中保存的数据存储到数组arr
Dim strOutput As String, strType As String
strType = "@abbreviation" ' 设置词条的类别
' ' 创建文件系统对象
' Set sfso = CreateObject("Scripting.FileSystemObject")
' ' 创建shell对象并赋值给变量 sh
' Set sh = CreateObject("shell.application")
' ' 通过shell打开文件浏览器窗口，交互地选择文件夹
' Set Folder = sh.BrowseForFolder(0, "", 0, "")
' ' 如果文件夹不为空文件夹，则获取文件夹的路径。这个路径是当前Excel文件所在的文件夹路径
' If Not Folder Is Nothing Then
' myPath = Folder.Items.Item.Path
' End If
' f = myPath & "\a.txt"
f = ThisWorkbook.Path & "\a.txt"
Open f For Output As #1 ' 以 Output 方式打开文件 f，文件编号为 #1
Print #1, "# Encoding: UTF-8" ' 写入文件的编码
Print #1, ' 写入空行
Dim strOne As String
For iRowCount = 2 To iRow
strOutput = strType & "{" & strArr(iRowCount, 1) & ","
Print #1, strOutput
For iColCount = 2 To iCol - 1
strOutput = " " & strArr(1, iColCount) & " = " & strArr(iRowCount, iColCount) & ","
Print #1, strOutput
Next iColCount
' 最后一行没有逗号，故特殊处理
strOutput = " " & strArr(1, iColCount) & " = " & strArr(iRowCount, iColCount)
Print #1, strOutput
Print #1, "} % End this Entry" ' 输出闭括号
Print #1, ' 输出空行
Next iRowCount
Close #1 ' 务必注意：关闭文件
MsgBox "共" & iRow - 1 & "个词条(Entries)，每个词条" & iCol & "个字段(Fields)"
End Sub
' 将工作簿某些工作表的指定行导出到一个 .txt 文件中。此为主函数，真正的导出功能是调用在下面的函数完成的
Sub Export()
Dim FileName As Variant ' 用于存储导出内容的 .txt 文件的文件名(完整路径)
Dim Sep As String ' 用何分隔符分隔单元格内容
Dim StartSheet As Integer ' 从第几个工作表开始导出
Dim EndSheet As Integer ' 导出到第几个工作表后就结束导出
Dim ExportIndex As Integer
'以对话框的形式让你选择用于存储导出内容的 .txt 文件：FileFilter 设置文件的过滤器
FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
'分隔符：用对话框的形式用户输入分隔符，比如常用的空格分隔、逗号分隔或制表符分隔
' Sep = Application.InputBox("Enter a separator character.", Type:=2)
'开始Sheet：用对话框的形式让用户输入”从第几个工作表开始导出“
'StartSheet = Application.InputBox("开始Sheet.", Type:=2)
'结束Sheet：用对话框的形式让用户输入”导出到第几个工作表后就结束导出“
EndSheet = Application.InputBox("结束Sheet.", Type:=2)
'导出行：用对话框的形式让用户输入”导出工作表的第几行“
ExportIndex = Application.InputBox("导出行号.", Type:=2)
' := 是给“方法”的内部子参数赋值时使用的，这一句没太懂其必要性
ShartSheet:=StartSheet, EndSheet:=EndSheet, ExportRow:=ExportIndex
' 调用函数导出”指定的多个工作表的指定行“
ExportRangeToTextFile FName:=CStr(FileName), SelectionOnly:=False, AppendData:=False, _
ShartSheet:=1, EndSheet:=EndSheet, ExportRow:=ExportIndex
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将Excel内多个Sheet中的某一行导出Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportRangeToTextFile(FName As String, _
SelectionOnly As Boolean, _
AppendData As Boolean, ShartSheet As Integer, _
EndSheet As Integer, ExportRow As Integer)
Dim WholeLine As String ' 用于拼接一整行的字符串变量
Dim FNum As Integer ' 用于保存文件序号，比如文件号 #1 中 1
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
Application.ScreenUpdating = False ' 关闭屏幕更新
On Error GoTo EndMacro: ' 如果出错则跳转到 EndMacro: 标记的行
FNum = FreeFile ' Open方法中，如果打开一个被使用的文件会出错误。FreeFile函数可以
' 取得文件序号，因此使用FreeFile函数返回的文件号则能避免出错
Open FName For Output Access Write As #FNum ' 打开文件
For i = 1 To Application.sheets.Count ' 遍历所有工作表
X = Application.sheets(i).UsedRange.Value ' 将工作表中已使用的单元格区域的值放到数组 X 中
WholeLine = "" ' 初始化字符串变量为空字符串，以备使用
' 获取已使用区域左上角和右下角单元格的行号和列表（相当于左上角和右下角单元格的坐标）
With Application.sheets(i).UsedRange
StartRow = .Cells(1).Row ' 已使用区域第1个单元格的行号（绝对行号，而不是相对于已使用区域）
StartCol = .Cells(1).Column ' 同上，但指的是列号
EndRow = .Cells(.Cells.Count).Row ' 已使用区域最后一个单元格的行号（绝对行好，而不是相对于已使用区域）
EndCol = .Cells(.Cells.Count).Column ' 同上，但指的是列号
End With
' 遍历已使用区域的 第1列 至 第EndCol列
For j = 1 To EndCol
' 将 第ExportRow行的 第1列 至 第EndCol列 的文本以制表符分隔，拼接成到字符串 WholeLine 中
WholeLine = WholeLine + X(ExportRow, j) + Chr("9") '单元格和单元格的文本以制表符间隔：Chr("9") <=> \t
Next
Print #FNum, WholeLine ' 将字符串输出到文件中
Next
MsgBox "OK" ' 导出完成后通过信息框提示一下
EndMacro: ' 如果发生了错误，则跳转到此行
On Error GoTo 0
Application.ScreenUpdating = True ' 重启屏幕更新
Close #FNum ' 关闭文件
'XT = Application.Transpose(X)转置
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 导出单个sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportSingleSheetToTextFile(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) ' 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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将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
' https://www.cnblogs.com/senion/articles/3660718.html
' 将工作簿某些工作表的指定行导出到一个 .txt 文件中。此为主函数，真正的导出功能是调用在下面的函数完成的
Sub Export()
Dim FileName As Variant ' 用于存储导出内容的 .txt 文件的文件名(完整路径)
Dim Sep As String ' 用何分隔符分隔单元格内容
Dim StartSheet As Integer ' 从第几个工作表开始导出
Dim EndSheet As Integer ' 导出到第几个工作表后就结束导出
Dim ExportIndex As Integer
'以对话框的形式让你选择用于存储导出内容的 .txt 文件：FileFilter 设置文件的过滤器
FileName = Application.GetSaveAsFilename(InitialFileName:=vbNullString, FileFilter:="Text Files (*.txt),*.txt")
If FileName = False Then
''''''''''''''''''''''''''
' user cancelled, get out
''''''''''''''''''''''''''
Exit Sub
End If
'分隔符：用对话框的形式用户输入分隔符，比如常用的空格分隔、逗号分隔或制表符分隔
' Sep = Application.InputBox("Enter a separator character.", Type:=2)
'开始Sheet：用对话框的形式让用户输入”从第几个工作表开始导出“
'StartSheet = Application.InputBox("开始Sheet.", Type:=2)
'结束Sheet：用对话框的形式让用户输入”导出到第几个工作表后就结束导出“
EndSheet = Application.InputBox("结束Sheet.", Type:=2)
'导出行：用对话框的形式让用户输入”导出工作表的第几行“
ExportIndex = Application.InputBox("导出行号.", Type:=2)
' := 是给“方法”的内部子参数赋值时使用的，这一句没太懂其必要性
ShartSheet:=StartSheet, EndSheet:=EndSheet, ExportRow:=ExportIndex
' 调用函数导出”指定的多个工作表的指定行“
ExportRangeToTextFile FName:=CStr(FileName), SelectionOnly:=False, AppendData:=False, _
ShartSheet:=1, EndSheet:=EndSheet, ExportRow:=ExportIndex
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将Excel内多个Sheet中的某一行导出Text
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportRangeToTextFile(FName As String, _
SelectionOnly As Boolean, _
AppendData As Boolean, ShartSheet As Integer, _
EndSheet As Integer, ExportRow As Integer)
Dim WholeLine As String ' 用于拼接一整行的字符串变量
Dim FNum As Integer ' 用于保存文件序号，比如文件号 #1 中 1
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
Application.ScreenUpdating = False ' 关闭屏幕更新
On Error GoTo EndMacro: ' 如果出错则跳转到 EndMacro: 标记的行
FNum = FreeFile ' Open方法中，如果打开一个被使用的文件会出错误。FreeFile函数可以
' 取得文件序号，因此使用FreeFile函数返回的文件号则能避免出错
Open FName For Output Access Write As #FNum ' 打开文件
For i = 1 To Application.sheets.Count ' 遍历所有工作表
X = Application.sheets(i).UsedRange.Value ' 将工作表中已使用的单元格区域的值放到数组 X 中
WholeLine = "" ' 初始化字符串变量为空字符串，以备使用
' 获取已使用区域左上角和右下角单元格的行号和列表（相当于左上角和右下角单元格的坐标）
With Application.sheets(i).UsedRange
StartRow = .Cells(1).Row ' 已使用区域第1个单元格的行号（绝对行号，而不是相对于已使用区域）
StartCol = .Cells(1).Column ' 同上，但指的是列号
EndRow = .Cells(.Cells.Count).Row ' 已使用区域最后一个单元格的行号（绝对行好，而不是相对于已使用区域）
EndCol = .Cells(.Cells.Count).Column ' 同上，但指的是列号
End With
' 遍历已使用区域的 第1列 至 第EndCol列
For j = 1 To EndCol
' 将 第ExportRow行的 第1列 至 第EndCol列 的文本以制表符分隔，拼接成到字符串 WholeLine 中
WholeLine = WholeLine + X(ExportRow, j) + Chr("9") '单元格和单元格的文本以制表符间隔：Chr("9") <=> \t
Next
Print #FNum, WholeLine ' 将字符串输出到文件中
Next
MsgBox "OK" ' 导出完成后通过信息框提示一下
EndMacro: ' 如果发生了错误，则跳转到此行
On Error GoTo 0
Application.ScreenUpdating = True ' 重启屏幕更新
Close #FNum ' 关闭文件
'XT = Application.Transpose(X)转置
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 导出单个sheet
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Sub ExportSingleSheetToTextFile(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) ' 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
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 将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
' 导出为 .csv 文件
' 该示例最重要的学习意义是使用文件系统来写入文本文件
Sub csv()
Dim ws As Worksheet
Dim i As Integer
Dim j As Integer
Dim fso As FileSystemObject
Dim path As String
Dim fd As Folder
Dim ts As TextStream
Dim s As String
Dim arr
path = ThisWorkbook.path & ""
Set fso = New FileSystemObject
Set fd = fso.GetFolder(path)
For Each ws In ThisWorkbook.Worksheets
s = "": arr = ws.Range("a1").CurrentRegion
For j = 1 To UBound(arr)
For i = 1 To UBound(arr, 2)
s = s & arr(j, i) & Chr(9)
Next
s = Left(s, Len(s) - 1)
s = s & vbCrLf
Next
Set ts = fd.CreateTextFile(ws.Name & ".txt")
ts.Write s
ts.Close
Next
End Sub
' 文本对齐
Sub 导出到文本文件()
Dim i%, iRow%
Dim S As String, S1, S2, S3, S4
Const FullName As String = "E:\导出到文本文件.txt"
Open FullName For Output As #1
iRow = ActiveSheet.Range("A65536").End(xlUp).Row
For i = 1 To iRow
S1 = Range("A" & i) ' 获取每行的 第1个 单元格
' 如果单元格文本的长度不大于4，那么在末尾补空格；如果长度大于4，则原样输出单元格文本。最后添加一个制表符。
S1 = IIf(Len(S1) <= 4, String(4 - Len(S1), " ") & S1, S1) & vbTab
S2 = Range("B" & i) ' 获取每行的 第1个 单元格
If S2 <> "" Then S2 = S2 & vbTab ' 如果单元格内容不为空则在单元格内容之后追加一个制表符
' 先将字符串S2从Unicode编码转换为单字节编码，然后获取字符串的总的字节数，接着用33减去字符串的字节数得剩余的字节数，再接着用剩余的字节数除以8（一个制表符占8个字节）并向下取整得到制表符的个数，最后用String函数生成该个数的制表符（因为在上一行已经追加了一个制表符，因此所有制表符的总长度是大于”剩余的字节数“的
S2 = S2 & String(Int((33 - LenB(StrConv(S2, vbFromUnicode))) / 8), vbTab)
' StrConv(<str>, <convert>，<locale>) ' 转换字符串
' 不同<convert>取值下函数的转换功能不同：
' 1 vbUpperCase 字符串中所有英文字转大写
' 2 vbLowerCase 字符串中所有英文字转小写
' 3 vbProperCase 字符串中第一个英文字大写
' 4 vbWide 将字符串中的窄（单字节）字符转换为宽（双字节）字符
' 8 vbNarrow 将字符串中的宽（双字节）字符转换为窄（单字节）字符
' 64 vbUnicode 所有Single Code字转成UniCode字
' 128 vbFromUnicode 将字符串从 Unicode 转换为系统的默认代码页，即所有UniCode字转成Single Code字
' 说明：
' 1. Signle Code指：以单一位元组(1Byte/8Bit)作为一个字的处理单位的字码；
' 2. UniCode指：由ISO(国际标准组织)订定的标准字码，以两个位元组(2Byte/16Bit)组成一个字，作为一个字处理单位的字码
S3 = Range("C" & i)
If S3 <> "" Then S3 = S3 & vbTab
S3 = S3 & String(Int((17 - LenB(StrConv(S3, vbFromUnicode))) / 8), vbTab)
S4 = Range("D" & i)
If S4 <> "" Then S4 = S4 & vbTab
S4 = S4 & String(Int((25 - LenB(StrConv(S4, vbFromUnicode))) / 8), vbTab)
' Debug.Print S1, S2, S3, S4
Print #1, S1 & S2 & S3 & S4
Next i
Close #1
End Sub
Sub bbb()
Dim i, ii, arr1(), arr2()
arr1 = [a1].CurrentRegion.Value
ReDim arr2(1 To UBound(arr1))
For i = 1 To UBound(arr1)
For ii = 1 To UBound(arr1, 2)
arr2(i) = arr2(i) & Chr(9) & Left(arr1(i, ii) & " ", 12)
Next
Next
Stop
s = Join(arr2, vbCrLf)
Open ThisWorkbook.Path & "\out1.txt" For Output As #1
Print #1, s
Close #1
Erase arr1, arr2
End Sub
String(<number>,<str>) '将字符串 <str> 填充 <number> 次，如 String(6,"ABCDE")
Left(arr1(i, ii) & " ", 12) ' 产生宽度为12且左对齐的字符串(末尾不空格)
Chr(9) ' 制表符
vbCrLf ' 回车换行符
vbTab ' vbTab 等同于是键盘上制表符TAB按键的功能，其长度为 8个 字符
Join(arr2, vbCrLf) ' 可以先组合每一行字符串，并将每一行放到字
' 符串数组中，最后再一次性在末尾添加回车换行符
arr1 = [a1].CurrentRegion.Value ' 相当于在单元格A1处按下 Ctrl+A 选中包括单元格A1在内的连续区域
Print #1, S1 & S2 & S3 & S4 ' 在打印文件时拼接字符串
Sub ParaConvertFromExcel2Matlab()
Dim rg As Range
' 获取活动工作表中已使用区域
Set rg = ActiveSheet.UsedRange
Dim iRow As Integer, iRowCount As Integer
Dim iCol As Integer, iColCount As Integer
Dim iParaNameLen As Integer, _
iParaScaleLen As Integer, _
iParaVectorLen As Integer
' 获取已使用区域的行数和列数
iRow = rg.Rows.Count
iCol = rg.Columns.Count
' 当参数为矩阵时，以下常量保存矩阵的行列数
Dim iRowMatrix As Integer, iColMatrix As Integer
Dim iRowMatrixCount As Integer
' 设置参数名和参数值的长度
Dim iLenTab As Integer
iLenTab = 8
iParaNameLen = 2 * iLenTab
iParaScaleLen = 1 * iLenTab
iParaVectorLen = 4 * iLenTab
' 判断注释是使用中文还是英文
Dim isChineseComent As Boolean, iLang As Integer
isChineseComent = 0
If isChineseComent = True Then
iLang = 5
Else
iLang = 4
End If
Dim strArr As Variant '定义一个Variant类型的变量，名称为strArr
strArr = rg.Value '将单元格区域的数据存储到数组strArr
' 打开用于输出的文件
Dim time_now
time_now = Format(Now, "yyyy-mm-dd h-mm-ss")
f = ThisWorkbook.Path & "\ExcelToMatlab_" & CStr(time_now) & ".txt"
Open f For Output As #1 ' 以 Output 方式打开文件 f，文件编号为 #1
' 用于拼接单元格内容的辅助字符串变量
Dim strOne As String, strVector As String
For iRowCount = 2 To iRow
' 如果为标量，那么
If strArr(iRowCount, 2) = "标量" Then
' 将参数名称写入字符串
strOne = Right(String(iParaNameLen, " ") & strArr(iRowCount, 1), iParaNameLen) & " = "
' 拼接标量参数值
strOne = strOne & Left(strArr(iRowCount, 3) & ";" & String(iParaScaleLen, " "), iParaScaleLen)
' 拼接标量的注释
strOne = strOne & vbTab & " % " & strArr(iRowCount, iLang)
' 如果为向量，那么
ElseIf strArr(iRowCount, 2) = "向量" Then
' 将参数名称写入字符串
strOne = Right(String(iParaNameLen, " ") & strArr(iRowCount, 1), iParaNameLen) & " = ["
' 拼接向量参数值
iColMatrix = strArr(iRowCount, 3) ' 向量的维度
' 开始拼接向量
strVector = ""
For iColCount = 3 To iColMatrix + 1
strVector = strVector & strArr(iRowCount + 1, iColCount) & "," & String(3, " ")
Next
strVector = strVector & strArr(iRowCount + 1, iColMatrix + 2) & "];"
' 调整向量的间隔
strOne = strOne & Left(strVector & String(iParaVectorLen, " "), iParaVectorLen)
' 拼接标量的注释
strOne = strOne & vbTab & " % " & strArr(iRowCount, iLang)
' 由于向量的数值占了一行，因此往下跳一行
iRowCount = iRowCount + 1
' 如果为矩阵，那么
ElseIf strArr(iRowCount, 2) = "矩阵" Then
' 获取矩阵的行数
strMatRowCol = Split(strArr(iRowCount, 3), "x")
iRowMatrix = strMatRowCol(0)
iColMatrix = strMatRowCol(1)
' MsgBox "矩阵的行数和列数为:" & iRowMatrix & "x" & iColMatrix
' 将参数名称写入字符串
strOne = Right(String(iParaNameLen, " ") & strArr(iRowCount, 1), iParaNameLen) & " = ["
' 处理矩阵
strMatrix = ""
For iRowMatrixCount = iRowCount + 1 To iRowCount + iRowMatrix
For iColCount = 3 To iColMatrix + 1
strMatrix = strMatrix & strArr(iRowMatrixCount, iColCount) & "," & String(3, " ")
Next
strMatrix = strMatrix & strArr(iRowMatrixCount, iColMatrix + 2) & ";" & vbCrLf & String(LenB(StrConv(strOne, vbFromUnicode)), " ")
Next
strMatrix = Left(strMatrix, Len(strMatrix) - Len(strOne & vbCrLf))
strOne = strOne & strMatrix & "];"
strOne = strOne & vbTab & " % " & strArr(iRowCount, iLang)
' 矩阵的数值占据了 iRowMatrix 行
iRowCount = iRowCount + iRowMatrix
' 其他任何情况均当做分节的注释，输出为：%% xxxxx
Else
strOne = "%% " & strArr(iRowCount, iLang)
End If
Print #1, strOne
' 处理下一行
Next iRowCount
Close #1 ' 务必注意：关闭文件
MsgBox "恭喜你，完成了这项艰巨的任务"
End Sub