如何根据excel表头字段批量将特定列复制到txt文件

ykcbf1100

小石榴123 发表于 2024-4-1 12:45
如示例1，想把每一个excel文件的JS、ZS、QL、C1、C2、C3、NC4、IC4、NC5、IC5这几列的数据复制到txt文件 ...

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.1
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     p = ThisWorkbook.Path & ""
   
7.     bt = [{"JS","ZS","QL","C1","C2","C3","NC4","IC4","NC5","IC5"}]
   
8.     On Error Resume Next
   
9.     For Each f In fso.GetFolder(p).Files
   
10.         If f.Name Like "*.xlsx" Then
    
11.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
12.                 fn = fso.GetBaseName(f)
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 d.RemoveAll
    
15.                 arr = wb.Sheets(1).UsedRange
    
16.                 ReDim brr(1 To 10000, 1 To UBound(bt))
    
17.                 wb.Close False
    
18.                 Set wb = Workbooks.Add
    
19.                 Set sht = wb.Sheets(1)
    
20.                 m = 0
    
21.                 With sht
    
22.                     .[a1].Resize(1, UBound(bt)) = bt
    
23.                     For j = 1 To UBound(bt)
    
24.                         d(bt(j)) = j
    
25.                     Next
    
26.                     For i = 2 To UBound(arr)
    
27.                         m = m + 1
    
28.                         For j = 1 To UBound(arr, 2)
    
29.                             s = arr(1, j)
    
30.                             brr(m, d(s)) = arr(i, j)
    
31.                         Next
    
32.                     Next
    
33.                     .[a2].Resize(m, UBound(bt)) = brr
    
34.                 End With
    
35.                 mFile = p & fn & ".txt"
    
36.                 wb.SaveAs Filename:=mFile, FileFormat:=xlText, CreateBackup:=True
    
37.                 wb.Close 1
    
38.             End If
    
39.         End If
    
40.     Next f
    
41.     Set d = Nothing
    
42.     Application.ScreenUpdating = True
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

baofa2

示例.zip (93.75 KB, 下载次数: 3)

2024-4-1 13:35 上传

点击文件名下载附件

小石榴123

ykcbf1100 发表于 2024-4-1 13:04
参与一下。。。

非常感谢，可以解决问题了

小石榴123

baofa2 发表于 2024-4-1 13:35

如果不用逗号分隔，应该怎么改代码呢

h2016

根据标题复制