Question

我从过去得到了帮助创建一个文件来使用这个线程导出值：

Export Excel range to TXT stop at empty cell

这可行但不完全符合我的要求。我有一个这样的列表（从A列开始）：

我想要的是，如果C列（重命名）具有值是，则列E的值为North，它应该做一些事情，然后导出到txt。

它应该取决于C和E列的结果。

示例：

If Rename is Yes and Place is South --> Do this.
If Rename is No and Place is South --> Do another thing.
If Rename is Yes and Place is North --> It does another thing.

依旧......

任何消化如何开始？

Sub SaveToTXT()
Dim filename As String, lineText As String
Dim myrng As Range, i, j

filename = ThisWorkbook.path & "\textfile-" & Format(Now, "ddmmyy-hhmmss") & ".txt"

Open filename For Output As #1

Set myrng = Range("A:B")

For i = 1 To myrng.Rows.Count
For j = 1 To myrng.Columns.Count

If IsEmpty(myrng.Cells(i, j)) = True Then Close #1
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "North" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "North" Then 'do something, yes replace'
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "South" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "South" Then 'do something, yes replace'
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "West" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "West" Then 'do something, yes replace'
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "East" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "East" Then 'do something, yes replace'
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "NorthEast" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "NorthEast" Then 'do something, yes replace'
If myrng(i, 3).Value = "No" And myrng(i, 5).Value = "SouthEast" Then 'do something, no replace'
If myrng(i, 3).Value = "Yes" And myrng(i, 5).Value = "SouthEast" Then 'do something, yes replace'
Exit Sub
End If

    lineText = IIf(j = 1, "", lineText & " ") & myrng.Cells(i, j)
Next j
Print #1, lineText
Next i
Close #1
End Sub

编辑/附录（参见用户评论）：“我想要的是所有具有相同匹配的内容都将添加到同一个txt.file中。 '我一共只能有12个文件，但如果这些不匹配则不应创建所有文件。 'txt文件也应该有不同的名称。“

Answer 1

通过数组和VBA Filter函数

进行逼近

在这里，您可以找到使用

的测试方法

完全限定参考以识别您当前的数据区域
常量使代码更具可读性
Arrays 来构建数据并使代码更快（循环遍历范围总是很慢）
辅助函数根据多个字符串输入获取一个整数代码（是|否，基数方向）而不是多达12 If 条件
VBA Filter函数根据搜索代码压缩数组数据，并允许对案例代码进行后续循环
允许对术语进行标记化的VBA Split函数
以下附加评论中列出的要求：

由于您的评论： “我想要的是所有具有相同匹配的内容都将添加到同一个txt.file中。我只能有12个文件，但如果IF THEN不匹配则不应创建所有文件。 txt文件也应该有不同的名称。“

注意请参阅代码中的注释以获取更多详细信息。

代码模块的声明主管

Option Explicit                 ' Declaration head of your codemodule
  Const NO = 0: Const YES = 1   ' Declare constants for ALL module procedures
  Const North = 1: Const East = 3: Const South = 5: Const West = 7
  Const NorthEast = 9: Const SouthEast = 11

主要程序

Sub SaveToTXT()
' --------------------------
' 1. Declarations
' --------------------------
' a) Declare constants for used columns C (=3rd col) and E (=5th col)
     Const RENAME = 3: Const PLACE = 5
' Declare variables
     Dim filename As String, oldFile As String
     Dim lineText As String, code As String, data
     Dim i        As Long     ' row counter
     Dim j        As Long     ' col counter
     Dim n        As Long     ' last data row
     Dim v        As Variant  ' receives 2-dimensional datafield array column A1:E{n}
     Dim a()      As Variant  ' 1-dimensional array to hold string code & linetext
     Dim fn       As Integer  ' free file number, INTEGER!
' b) Declare Worksheet object
     Dim ws As Worksheet
' --------------------------
' 2. Get data
' --------------------------
' a) Define sheet name and set ws object to memory
     Set ws = ThisWorkbook.Worksheets("SaveToText")  ' << change to your sheet name :-)
' b) get last row of your sheet, assuming you have values in every row of column A!
     n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' c) create 2-dim datafield array from A:F .. plus 1 array column to hold conditions
'    (becomes automatically 2-dimensional with 1-based indexation!)
     v = ws.Range("A1:E" & n).Value        ' A:E = 5 data columns
' d) create 1-dim array to hold lines and make it 1-based ("1 To ..")
     ReDim a(1 To n)
' --------------------------
' 3. Prepare data for output
' --------------------------
  For i = 2 To n               ' loop through array rows (omitting 1 title row)
     ' a) create case codes 1-12 depending on YES|NO plus cardinal direction
          code = chkRename(v(i, RENAME)) + chkPlace(v(i, PLACE))
     ' b) concatenate columns B to E, insert delimiter " " and omit column A
          lineText = Split(Join(Application.Index(v, i, 0), " "), " ", 2)(1)
     ' c) write code & lineText to array a
          a(i) = code & "|" & lineText
          ' Debug.Print "row: " & i, "code: " & code, lineText
  Next i
' --------------------------
' 4. Write to 1-12 textfiles (North to SouthEast, marked with "(x)" in case of NO)
' --------------------------
  On Error Resume Next: Close #fn
' Loop through codes 1-12 and filter array a(1-n) holding all code|lineText strings
  For j = North To SouthEast + YES      ' loop from code 1 to 12
   ' ---------------------
   ' 4.1 Filter array data
   ' ---------------------
         data = Filter(a, j & "|")      ' filter with search code j (1-12) & Delimiter!
   ' ---------------------
   ' 4.2 Check if there are any filtered data available
   ' ---------------------
    If UBound(data) > -1 Then
     ' -------------------
     ' 4.3 Prepare writing
     ' -------------------
     ' a) get one of 12 filenames depending on individual case code
          filename = getFileName(j)     ' << helper function to build filename
       If filename <> oldFile Then
        ' b) assign oldFile and close it
             oldFile = filename
             If oldFile <> "" Then Close #fn
        ' c) open new file
             fn = FreeFile
             Open filename For Output As #fn
       End If
     ' ----------------
     ' 4.4   Write data
     ' ----------------
       For i = LBound(data) To UBound(data)
        ' a) get linetext
             lineText = Split(data(i), "|")(1) ' get second portion of term (=index 1)
        ' b) print lineText to file
             Print #fn, lineText
             ' Debug.Print " code " & j & ": " & filename, lineText
        Next i

      End If                ' end of condition data available for code j
  Next j
  On Error Resume Next: Close #fn   
End Sub

Sub SaveToTXT使用的辅助函数

这些辅助函数根据RENAME列中的Yes | No值和PLACE列中的Cardinal方向生成整数代码注意使用定义的常量。

（1）功能chkRename

Function chkRename(ByVal YesNo) As Integer
' Purpose: code string input "Yes" to 1, "No" to 0
  chkRename = IIf(UCase(YesNo) = "YES", YES, NO)
End Function

（2）功能chkPlace

Function chkPlace(ByVal CardinalDirection) As Integer
' Purpose: code string argument to integer 
' (steps of two to allow adding YES=1|NO=0 codes)
Dim a()
Dim i As Integer
' Keep this order, terms East or North have to be before NorthEast and SouthEast,
' as the function filters the search term CardinalDirction and
' returns the first finding with its 2nd portion, i.e. number 1-11, indicated by split index 1
' (otherwise "East" would be contained in SouthEast for example and found there first!)
  a = Array("North 1", "East 3", "South 5", "West 7", "NorthEast 9", "SouthEast 11")
' return
  chkPlace = Split(Filter(a, CardinalDirection)(0), " ")(1)
End Function

（3）功能getFileName

Function getFileName(ByVal code) As String
' Purpose: build file name depending on code for cardinal direction plus Yes|No code
' Example: North + YES is converted to "N" only, North + No to "N(x)"
'          => e.g. path & "\textfile_310118_N(x).txt"
' Caveat:  split string has to start with "Dummy,..."
  Dim v As Variant
  Dim i As Integer
  v = Split("Dummy,N,N(x),E,E(x),S,S(x),W,W(x),NE,NE(x),SE,SE(x)", ",")
' return
 getFileName = ThisWorkbook.Path & "\textfile_" & Format(Now, "ddmmyy") & "_" & v(val(code)) & ".txt"
End Function

Answer 2

在上一个答案中的for循环内，你可以有几个IF THEN语句来实现这个目标

e.g。 If myrng(i,3).value = "Yes" and myrng(i,5).value = "North" Then 'do something'

我希望有帮助

Excel VBA - 条件导出到TXT（各种文本文件）

2 个答案: