|
- Sub 目录()
- Set Mapp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件目录:", &H1)
- If Not Mapp Is Nothing Then ActiveCell.Value = Mapp.self.Path
- End Sub
- Sub 导入Txt()
- Dim cPath$, cFile$, n%, Arr, Brr, Crr()
- Dim wb As Workbook, sh As Worksheet
- If Dir(Range("c2").Value, 16) <> "" Then
- cPath = Range("c2").Value
- If Right(cPath, 1) <> "" Then cPath = cPath & ""
- Else
- cPath = ThisWorkbook.Path & ""
- End If
- cFile = Dir(cPath & "*.txt")
- Application.ScreenUpdating = False
- Set wb = Workbooks.Add
- With wb
- Do While cFile <> ""
- Open cPath & cFile For Input As #1
- Arr = Split(StrConv(InputB(LOF(1), 1), vbUnicode), Chr(10))
- Close #1
- ReDim Crr(0 To UBound(Arr), 0 To 10)
- For i = 0 To UBound(Arr)
- If Arr(i) <> "" Then
- Brr = Split(Arr(i), Chr(9))
- For j = 0 To UBound(Brr)
- Crr(i, j) = Brr(j)
- Next
- End If
- Next
- n = n + 1
- If n > .Sheets.Count Then
- Set sh = .Sheets.Add(After:=Sheets(n - 1))
- Else
- Set sh = .Sheets(n)
- End If
- sh.Range("a1").Resize(UBound(Arr) + 1, 11).Value = Crr
-
- sh.Name = Split(cFile, " ")(0)
- cFile = Dir
- Loop
- If Dir(Range("c3").Value, 16) <> "" Then
- cPath = Range("c3").Value
- If Right(cPath, 1) <> "" Then cPath = cPath & ""
- End If
- .SaveAs cPath & Format(Now, "yyyymmdd hhmmss")
- End With
- Application.ScreenUpdating = True
- ThisWorkbook.Close
- End Sub
复制代码 为什么会出现:'命名重复'
求助大佬
|
|