Пятница, 2017-12-15, 1:41 AM

    farmir

    Главная | Регистрация | Вход

    RSS
    Статистика
    Поиск картинки по тегам/музыки по названию

    Макросы Excel - Бардачок


    [ Новые сообщения · Участники · Правила форума · Поиск · RSS ]
    Страница 1 из 11
    Бардачок » Useful things » Софт » Макросы Excel
    Макросы Excel
    EllthruДата: Четверг, 2015-12-10, 10:50 AM | Сообщение # 1
    Admin
    Группа: Администраторы
    Сообщений: 662
    Репутация: 24
    Статус: Не в сети
    Сбор нескольких текстовых файлов в отдну таблицу.
    Каждый текстовый файл на отдельном листе.

    Код
    Sub CombineTextFiles()
        Dim FilesToOpen
        Dim x As Integer
        Dim wkbAll As Workbook
        Dim wkbTemp As Workbook
        Dim sDelimiter As String

        On Error GoTo ErrHandler
        Application.ScreenUpdating = False

        sDelimiter = "|"

        FilesToOpen = Application.GetOpenFilename _
          (FileFilter:="Text Files (*.txt), *.txt", _
          MultiSelect:=True, Title:="Text Files to Open")

        If TypeName(FilesToOpen) = "Boolean" Then
            MsgBox "No Files were selected"
            GoTo ExitHandler
        End If

        x = 1
        Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
        wkbTemp.Sheets(1).Copy
        Set wkbAll = ActiveWorkbook
        wkbTemp.Close (False)
        wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
          Destination:=Range("A1"), DataType:=xlDelimited, _
          TextQualifier:=xlDoubleQuote, _
          ConsecutiveDelimiter:=False, _
          Tab:=False, Semicolon:=False, _
          Comma:=False, Space:=False, _
          Other:=True, OtherChar:="|"
        x = x + 1

        While x <= UBound(FilesToOpen)
            Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
            With wkbAll
                wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
                .Worksheets(x).Columns("A:A").TextToColumns _
                  Destination:=Range("A1"), DataType:=xlDelimited, _
                  TextQualifier:=xlDoubleQuote, _
                  ConsecutiveDelimiter:=False, _
                  Tab:=False, Semicolon:=False, _
                  Comma:=False, Space:=False, _
                  Other:=True, OtherChar:=sDelimiter
            End With
            x = x + 1
        Wend

    ExitHandler:
        Application.ScreenUpdating = True
        Set wkbAll = Nothing
        Set wkbTemp = Nothing
        Exit Sub

    ErrHandler:
        MsgBox Err.Description
        Resume ExitHandler
    End Sub
     
    Бардачок » Useful things » Софт » Макросы Excel
    Страница 1 из 11
    Поиск:

    Copyright MyCorp © 2017
    Сделать бесплатный сайт с uCoz