有关vba的，关于excel文件输入输出到txt里面，并且文件名以某个单元格为主
本帖最后由 cherrycdh 于 2022-11-23 17:23 编辑有大神来解惑一下么？编程小白没学好
就是想要一个功能，当我点击一个按钮的时候（比如说点击开始按钮）
然后我需要先在指定的盘符下面查看是否有和单元格中某一个数值相同的文件
比如说我cells（4，3）的内容是432955，然后呢，我先要让vba查询一下，在D盘的缓存文件夹下面是否有相同的一个432955的txt文件
如果有的话，那就将432955的内容填入到指定的单元格中，比如我将第一行填入到cells(5,3),第二行填入到cells（5，4）这样
如果没有的话，那就将在D盘缓存文件夹下面创建一个以cells（4，3）内容为文件名的一个txt文件，并且将cells（5，3），cells（5，4）这些指定单元格的内容写入到txt文件下
当我点击结束按钮的时候，将d盘缓存文件夹下创建的所有txt文件删除
我自己也写了一个文件，目前来说写入和读取是正常的，就是我又发现了一个问题，原则情况下，我那个缓存文件夹下面只会有0个或者1个文件存在，那会不会有vba运行出错的情况下，导致最后点击结束按钮的时候缓存文件没有删除，然后明明文件夹下面有那个文件但系统认定没有（因为刚问了另外一位小伙伴，他说不会报错但是只会读取第一个文件）
Sub 缓存文件()
Dim s As String
Dim FileName As String
Dim i As Long
FileName = Dir("d:\缓存文件\*.*")
If FileName <> "" Then
i = Left(FileName, 6)
End If
Dim str() As String
If Cells(2, 2) = i Then
Application.ScreenUpdating = False '关闭屏幕刷新建议在进行代码执行时加入这句，与最后的开启呼应
ActiveSheet.Unprotect ("lixia2015") '对工作表进行解密操作
Open "d:\缓存文件\" & FileName For Input As #1
Line Input #1, s
Cells(4, 5) = s
Line Input #1, s
Cells(6, 5) = s
Line Input #1, s
Cells(7, 5) = s
Line Input #1, s
Cells(8, 5) = s
Line Input #1, s
Cells(10, 5) = s
Line Input #1, s
Cells(11, 5) = s
Line Input #1, s
Sheet3.Cells(23, 5) = s
Sheet1.Activate
ActiveSheet.Protect ("lixia2015")
Else
Open "d:\缓存文件\" & Cells(2, 2).Value & ".txt" For Append As #1
Print #1, Trim(Cells(4, 5))
Print #1, Trim(Cells(6, 5))
Print #1, Trim(Cells(7, 5))
Print #1, Trim(Cells(8, 5))
Print #1, Trim(Cells(10, 5))
Print #1, Trim(Cells(11, 5))
Print #1, Trim(Sheet3.Cells(23, 5))
Close #1 '一定要关闭文本文件，不然会出错
End If
End Sub
感谢楼主的分享 我现在想出了第一层关键，请大神们看下对不对
Sub 输出文件()
Dim s As String
'提取文件名
Dim FileName As String
Dim i As Long
FileName = Dir("d:/缓存文件/*.*")
i = Left(FileName, 6)
If Cells(4, 3) = i Then
MsgBox "文件夹下面有文件需要将内容导入"
Else
MsgBox "没有文件需要创建并将指定单元格内容导出"
End If 向楼主学习一下哈Vba 多谢分享 一个excel只需要处理一个cells（4，3）吗
我猜后面还要加需求 这个是我自己写的根据指定单元格字段，自动判断，创建文件夹，文档移入文件夹内的代码，你可以借鉴一些
Sub test()
Dim fldr As FileDialog
Dim f, ibox, sn, f1
Dim i, i1, i2, r, i3, k1, k, lj, lj1, lj2, arr1, arr, brr, crr, drr, t, arr2, t1
Dim sPath As String
Dim oShell As Object
Dim MyName As String, folders As Object
Application.ScreenUpdating = False
'通过cmd命令，获取选取文件夹下的所有文件路径，写入sheet2中
Sheet2.Range("A:E").Clear
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
On Error GoTo ext
fldr.Show
f = fldr.SelectedItems(1)
sPath = f
f = f & "\"
ibox = "*.pdf*"
sn = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & f & ibox & """ /s /a /b").stdout.readall, vbCrLf)
Sheets(2).Cells(1).Resize(UBound(sn) + 1) = Application.Transpose(sn)
ext:
If Err.Number = 5 Then
MsgBox ("你点了取消")
Exit Sub
End If
'整理获取路径下的所有文件需求名
With Sheet2
i = 1
Do While .Range("A" & i) <> ""
.Range("B" & i) = Right(.Range("A" & i), Len(.Range("A" & i)) - InStrRev(.Range("A" & i), "\"))
i1 = InStr(.Range("B" & i), "-")
i2 = InStrRev(.Range("B" & i), "-")
.Range("C" & i) = Replace(Mid(.Range("B" & i), i1 + 1, i2 - i1), "-", "")
'.Range("D" & i) = Left(.Range("A" & i), InStrRev(.Range("A" & i), "\") - 1)
'.Range("D" & i) = Left(Right(.Range("D" & i), Len(.Range("D" & i)) - InStrRev(.Range("D" & i), "\")), 4)
i = i + 1
Loop
End With
'整理需要创建的文件夹名称
With Sheet1
i3 = 2
Do While .Range("A" & i3) <> ""
r = .Range("p1048576").End(xlUp).Row + 1
.Range("p" & r) = .Range("G" & i3) & "、" & .Range("H" & i3) '为了创建文件夹名称
.Range("J" & r) = .Range("G" & i3) & "、" & .Range("H" & i3) '为了后续路径判断
i3 = i3 + 1
Loop
Call quchong
'开始创建文件夹
On Error GoTo elujing
For k = 1 To .Range("P1048576").End(xlUp).Row
lj = f & .Cells(k, 16)
MkDir lj
Next
elujing:
If Err.Number = 75 Then
MsgBox ("已经建立了文件夹，请删除后重新分类")
Exit Sub
End If
'开始条件判断，移动文件进文件夹
Set arr1 = CreateObject("Scripting.FileSystemObject")
arr = Sheet1.Range("A1").CurrentRegion.Value
brr = Sheet2.Range("A1").CurrentRegion.Value
For i = 2 To UBound(arr, 1)
For j = 1 To UBound(brr, 1)
crr = arr(i, 1)
drr = brr(j, 3)
If crr = drr Then
Sheet2.Range("D" & j) = arr(i, 10)
f1 = f & Sheet2.Range("D" & j) & "\"
arr1.copyfile brr(j, 1), f1
End If
Next
Next
'判断未分类的文件，复制到外面
Set arr2 = CreateObject("Scripting.FileSystemObject")
t = 1
t1 = 1
Do While Sheet2.Range("A" & t) <> ""
If Sheet2.Range("D" & t) = "" Then
arr2.copyfile Sheet2.Range("A" & t), f
t1 = t1 + 1
End If
t = t + 1
Loop
End With
Sheet1.Range("J:Q").Delete
MsgBox ("已完成全部分类，请查看，共有" & t1 & "个PDF未分类")
Application.ScreenUpdating = True
'打开分类文件夹
Set oShell = VBA.CreateObject("shell.application")
With oShell
.Open (sPath)
End With
End Sub
Sub quchong()
Dim i, j, k, s, arr
Set s = CreateObject("Scripting.Dictionary")
arr = Range("P2").CurrentRegion
For j = 1 To UBound(arr)
If Not s.Exists(arr(j, 1)) Then
s(arr(j, 1)) = ""
End If
Next
Range("P:P").ClearContents
Range("P1").Resize(s.Count, 1) = Application.Transpose(s.Keys)
Set s = Nothing
End Sub
这个代码是批量操作text文件的，可以打开读取和编辑Sub 遍历所有txt文件()
Dim 文件
'运行Dir函数得到第1个文件的名字
Dim i, j, j1, k, s, r, r1, j2, j3, k1, k2, r4
Dim arr, brr, crr, drr
'文件夹路径选择
Set crr = Application.FileDialog(msoFileDialogFolderPicker)
With crr
.AllowMultiSelect = True
.InitialFileName = "E:\"
.Title = "选择归类文件夹"
If .Show = 0 Then
MsgBox "你点了取消"
Else
k = crr.SelectedItems(1) & "\"
End If
End With
文件 = Dir(k)
'如果读到的文件不是空字符串，就证明这是一个有效文件
Do While 文件 <> ""
'这里可以对文件进行打开和读取操作
文件 = Dir '再次运行Dir就读到下一个文件名
Loop
End Sub
JackLei 发表于 2022-11-23 13:32
这个是我自己写的根据指定单元格字段，自动判断，创建文件夹，文档移入文件夹内的代码，你可以借鉴一些
恩恩，感谢，不过我跟这个有点不一样，因为我只需要判断单元格里的数据内容是否跟文件夹里面的文件名相同，有的话就可以导入，因为我最后需要有一个删除所有文本文件的功能，所以一般来说是不需要遍历整个文件夹里
其实我需要的是一个缓存数据，因为同事使用的是一个只读的excel文件，当他们输入数据后，会在桌面实时显示数据进行的状态，然后等到完成之后是将整体的数据导入到数据库中的
然后有了一个意外，因为会发生同事不小心把文件关了，或者死机了之类的，那么如果有那个缓存的数据，就避免关机或者死机了需要我手动跑过去给他们更改 学习一下，关键时候用得上。