VBA: Прочитайте несколько текстовых файлов и составьте лист Excel для каждого из них в конце моей текущей рабочей книги. - PullRequest
Новая
       6

VBA: Прочитайте несколько текстовых файлов и составьте лист Excel для каждого из них в конце моей текущей рабочей книги.

0 голосов
/ 11 января 2019

Привет, я новичок в VBA и в настоящее время работаю над проектом, в котором мне нужно прочитать много файлов (выбрать их с помощью мыши) и поместить данные, которые смещены пробелом, в лист exel в моей текущей книге (но на конец моих листов, потому что у меня уже есть листы, которые должны оставаться в начале) Я использую.

Я нашел код, который почти делает то, что мне нужно, но:

  • Этот код не может открыть все файлы, потому что имя файла содержит более 30 букв.

текстовый файл выглядит так: «name1_name2_name3_name4_name5_name6.txt», если возможно найти определенное имя, например name1,3,4, достаточно, чтобы узнать, какой это файл. Я спрашиваю потому что Я должен объединить несколько файлов в один лист, если имя1 имя2 совмещено.

  • он открывает нужную книгу вместо того, чтобы поместить новые листы в мою текущую книгу

Код например 

Sub ReadText()
Dim xFilesToOpen As Variant
Dim I As Integer

Dim xWb As Workbook
Dim xTempWb As Workbook
Dim xDelimiter As String

Dim xScreen As Boolean
On Error GoTo ErrHandler
xScreen = Application.ScreenUpdating
Application.ScreenUpdating = False
xDelimiter = "|"
xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Error", , True)

'falls nichts ausgewählt abbrechen
If TypeName(xFilesToOpen) = "Boolean" Then
    MsgBox "No files were selected", , "Error"
    GoTo ExitHandler
End If
''''''''''''''''''''''''
'nächste Code Schritte
I = 1
Set xTempWb = Workbooks.Open(xFilesToOpen(I))
xTempWb.Sheets(1).Copy
Set xWb = Application.ActiveWorkbook
xTempWb.Close False
xWb.Worksheets(I).Columns("A:A").TextToColumns _
  Destination:=Range("A1"), DataType:=xlDelimited, _
  TextQualifier:=xlDoubleQuote, _
  ConsecutiveDelimiter:=False, _
  Tab:=False, Semicolon:=False, _
  Comma:=False, Space:=False, _
  Other:=True, OtherChar:="|"

Do While I < UBound(xFilesToOpen)
    I = I + 1
    Set xTempWb = Workbooks.Open(xFilesToOpen(I))
    With xWb
        xTempWb.Sheets(1).Move after:=.Sheets(.Sheets.Count)
        .Worksheets(I).Columns("A:A").TextToColumns _
          Destination:=Range("A1"), DataType:=xlDelimited, _
          TextQualifier:=xlDoubleQuote, _
          ConsecutiveDelimiter:=False, _
          Tab:=False, Semicolon:=False, _
          Comma:=False, Space:=False, _
          Other:=True, OtherChar:=xDelimiter
    End With
Loop
''''''''''''''''''
'Falls keine File ausgewählt springt er hier her
ExitHandler:
    Application.ScreenUpdating = xScreen
    Set xWb = Nothing
    Set xTempWb = Nothing
    Exit Sub
ErrHandler:
    MsgBox Err.Description, , "Error"
    Resume ExitHandler
End sub

Есть ли кто-нибудь, кто может помочь мне решить эту проблему с помощью этого кода? Или есть более простой способ программирования, что мне нужно

1 Ответ

0 голосов
/ 11 января 2019
*

Попробуйте * 1001 

Sub ReadText()
    Dim xFilesToOpen As Variant
    Dim i As Integer

    Dim xWb As Workbook
    Dim xTempWb As Workbook
    Dim xDelimiter As String
    Dim xScreen As Boolean
    Dim vDB As Variant
    Dim Ws As Worksheet, Target As Range

    On Error GoTo ErrHandler

    xScreen = Application.ScreenUpdating
    Application.ScreenUpdating = False

    Set Ws = ThisWorkbook.Sheets(1) '<~~ set sheet that you want.

    xFilesToOpen = Application.GetOpenFilename("Text Files (*.txt), *.txt", , "Error", , True)


    'falls nichts ausgewahlt abbrechen
    If TypeName(xFilesToOpen) = "Boolean" Then
        MsgBox "No files were selected", , "Error"
        GoTo ExitHandler
    End If
    ''''''''''''''''''''''''
    'nachste Code Schritte

    For i = 1 To UBound(xFilesToOpen)

        Set xTempWb = Workbooks.Open(xFilesToOpen(i), Format:=1)
        '@@ format number ;  1= tab, 2= comma,3=space, 4=semicolon ,5= none, 6= user delimiter
        'vDB = xTempWb.Sheets(1).Range("a1").CurrentRegion '<~~ if there are empty rows or columns, this can not get data beyond that.
        vDB = xTempWb.Sheets(1).UsedRange '<~ get sheet's whole data
        Set Target = Ws.Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
        Target.Resize(UBound(vDB, 1), UBound(vDB, 2)) = vDB
        xTempWb.Close (0)
    Next i
    ''''''''''''''''''
    'Falls keine File ausgewahlt springt er hier her
ExitHandler:
        Application.ScreenUpdating = xScreen
        Set xWb = Nothing
        Set xTempWb = Nothing
        Exit Sub
ErrHandler:
        MsgBox Err.Description, , "Error"
        Resume ExitHandler
End Sub
...