Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Сбор информации на один лист - Мир MS Excel

  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_, DrMini  
Сбор информации на один лист
Volodya Дата: Вторник, 26.09.2017, 06:56 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Есть несколько файлов с расширением .csv. Информацию из этих файлов нужно закинуть в .xls-файл на один лист. Использую код, приведенный ниже. Но проблема в том, что когда программа собирает информацию с разных листов, "съедается" часть информации с предыдущего листа - следующим. Подскажите как исправить?[vba]
Код
Public Sub www()
    Dim i&, f$, ws As Worksheet
    Application.ScreenUpdating = 0
    f = Dir(ThisWorkbook.Path & "\" & "*.csv")
    Do While f <> ""
        With Workbooks.Open(ThisWorkbook.Path & "\" & f, Origin:=xlWindows, local:=-1)
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = Left(f, InStr(1, f, ".") - 1)
            .Sheets(1).Range("A1").CurrentRegion.Copy ws.[a1]
            .Close 0
        End With
        f = Dir()
    Loop
    Sheets("stock").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Range("A1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stocka").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockkolp").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockm").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockp").Select
Range(("A1:AA1"), Range("A1:AA1").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Range("A1").Select
    Selection.Insert Shift:=xlDown
    ActiveSheet.Paste
    Application.DisplayAlerts = False
    Sheets("stock").Delete
    Sheets("stockm").Delete
    Sheets("stockp").Delete
    Sheets("stockA").Delete
    Sheets("stockkolp").Delete
Dim StrA As String
Dim StrB As String
Dim StrC As String
    With ActiveWorkbook
    StrA = .Path & "\"
    StrB = Left(.Name, InStr(1, .Name, ".xls") - 1)
    StrC = "distributor278_" & Replace(Format(Date, "MM_YY"), ".", "") & ".xls"
    .SaveAs Filename:=StrA & StrC
    ActiveWorkbook.Save
    Application.Quit
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = -1
End With
End Sub
[/vba]


Сообщение отредактировал Volodya - Вторник, 26.09.2017, 06:57
 
Ответить
СообщениеЕсть несколько файлов с расширением .csv. Информацию из этих файлов нужно закинуть в .xls-файл на один лист. Использую код, приведенный ниже. Но проблема в том, что когда программа собирает информацию с разных листов, "съедается" часть информации с предыдущего листа - следующим. Подскажите как исправить?[vba]
Код
Public Sub www()
    Dim i&, f$, ws As Worksheet
    Application.ScreenUpdating = 0
    f = Dir(ThisWorkbook.Path & "\" & "*.csv")
    Do While f <> ""
        With Workbooks.Open(ThisWorkbook.Path & "\" & f, Origin:=xlWindows, local:=-1)
        Set ws = ThisWorkbook.Worksheets.Add
        ws.Name = Left(f, InStr(1, f, ".") - 1)
            .Sheets(1).Range("A1").CurrentRegion.Copy ws.[a1]
            .Close 0
        End With
        f = Dir()
    Loop
    Sheets("stock").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Range("A1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stocka").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockkolp").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockm").Select
Range(("A2:AA2"), Range("A2:AA2").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Set cell = [a1].End(xlDown)
    ActiveSheet.Paste
    Sheets("stockp").Select
Range(("A1:AA1"), Range("A1:AA1").End(xlDown)).Select
    Selection.Copy
    Sheets("Лист1").Select
    Range("A1").Select
    Selection.Insert Shift:=xlDown
    ActiveSheet.Paste
    Application.DisplayAlerts = False
    Sheets("stock").Delete
    Sheets("stockm").Delete
    Sheets("stockp").Delete
    Sheets("stockA").Delete
    Sheets("stockkolp").Delete
Dim StrA As String
Dim StrB As String
Dim StrC As String
    With ActiveWorkbook
    StrA = .Path & "\"
    StrB = Left(.Name, InStr(1, .Name, ".xls") - 1)
    StrC = "distributor278_" & Replace(Format(Date, "MM_YY"), ".", "") & ".xls"
    .SaveAs Filename:=StrA & StrC
    ActiveWorkbook.Save
    Application.Quit
    ActiveWorkbook.Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = -1
End With
End Sub
[/vba]

Автор - Volodya
Дата добавления - 26.09.2017 в 06:56
Kuzmich Дата: Вторник, 26.09.2017, 08:06 | Сообщение № 2
Группа: Проверенные
Ранг: Ветеран
Сообщений: 717
Репутация: 159 ±
Замечаний: 0% ±

Excel 2003
Зачем создавать кучу листов, если можно сразу копировать данные из файлов .csv на Лист1 файла Excel ?
 
Ответить
СообщениеЗачем создавать кучу листов, если можно сразу копировать данные из файлов .csv на Лист1 файла Excel ?

Автор - Kuzmich
Дата добавления - 26.09.2017 в 08:06
Volodya Дата: Вторник, 26.09.2017, 09:16 | Сообщение № 3
Группа: Пользователи
Ранг: Новичок
Сообщений: 38
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Kuzmich, подскажи как. У меня не получилось.
 
Ответить
СообщениеKuzmich, подскажи как. У меня не получилось.

Автор - Volodya
Дата добавления - 26.09.2017 в 09:16
_Boroda_ Дата: Вторник, 26.09.2017, 09:25 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 17006
Репутация: 6667 ±
Замечаний: ±

2003; 2007; 2010; 2013 RUS
Посмотрите здесь готовый код
http://excelvba.ru/code/DATfolder2Array


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПосмотрите здесь готовый код
http://excelvba.ru/code/DATfolder2Array

Автор - _Boroda_
Дата добавления - 26.09.2017 в 09:25
  • Страница 1 из 1
  • 1
Поиск:

Яндекс.Метрика Яндекс цитирования
© 2010-2026 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!