EXCEL中如何用VBA实现将EXCEL内容复制到E盘中新建的文档里？并循环使用

Question

EXCEL中如何用VBA实现将EXCEL内容复制到E盘中新建的文档里？并循环使用
结果如下：
1，E盘新建第1个TEXT文档（命名：测试1）并将B1:B200数据复制到该文档
2，E盘新建第2个TEXT文档（命名：测试2）.并将B201:B400数据复制到该文档
....
2，E盘新建第2个TEXT文档（命名：测试XX）.并将B9701:B10000数据复制到该文档
最好能自己判断从B2开始每200复制一次 ，可以的话B列 复制完 紧接着复制D列再紧接复制S列

不要并行的，要串行的。就是不要B\D\S三列同时复制粘贴

Answer 1

Sub EXCEL内容复制文档()
  Dim lStartRow As Long
  Dim lEndRow As Long
  Dim lRow As Long
  Dim lCount As Long
  Dim Arr
  Dim str As String
  Dim objFSO As Object
  Dim objText As Object
  Set objFSO = CreateObject("Scripting.FileSystemObject")
  lStartRow = 1
  lEndRow = Range("B65536").End(xlUp).Row
  Arr = Range("B" & lStartRow & ":B" & lEndRow)
  lCount = 0
  For lRow = lStartRow To lEndRow
    If (lRow - lStartRow) Mod 200 = 0 Then
      lCount = lCount + 1
      If Not objText Is Nothing Then objText.Close
      Set objText = objFSO.CreateTextFile("E:\测试" & lCount & ".txt")
    End If
    objText.WriteLine Arr(lRow, 1)
  Next
  
  lEndRow = Range("D65536").End(xlUp).Row
  Arr = Range("D" & lStartRow & ":D" & lEndRow)
  For lRow = lStartRow To lEndRow
    If (lRow - lStartRow) Mod 200 = 0 Then
      lCount = lCount + 1
      If Not objText Is Nothing Then objText.Close
      Set objText = objFSO.CreateTextFile("E:\测试" & lCount & ".txt")
    End If
    objText.WriteLine Arr(lRow, 1)
  Next
  
  lEndRow = Range("S65536").End(xlUp).Row
  Arr = Range("S" & lStartRow & ":S" & lEndRow)
  For lRow = lStartRow To lEndRow
    If (lRow - lStartRow) Mod 200 = 0 Then
      lCount = lCount + 1
      If Not objText Is Nothing Then objText.Close
      Set objText = objFSO.CreateTextFile("E:\测试" & lCount & ".txt")
    End If
    objText.WriteLine Arr(lRow, 1)
  Next
  
  objText.Close
  Set Arr = Nothing
  Set objText = Nothing
  Set objFSO = Nothing
End Sub

追问

有没有办法将B\D\S列 都放在一个TEXT文档里？

追答

可以，但是你的问题是200行创建一个txt文档。

Answer 2

make a mark , 有空回来 就 写个

====================

 Sub ctxt()
  Dim f As String
   arr = Array("B", "D", "S")
   For c = 0 To UBound(arr)
     For i = 1 To 10000 Step 200
      f = E & "新建文件夹\" & arr(c) & i & ".txt"
       Open f For Output As #1
         For t = i To i + 199
           Print #1, Cells(t, arr(c))
          Next
           Close #1
      Next
    Next
  End Sub