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

Вход

Регистрация

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

 

= Мир MS Excel/Перенос/копирование данных с изменением формата ячеек - Мир MS Excel

Старая форма входа
  • Страница 1 из 1
  • 1
Модератор форума: китин, _Boroda_  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос/копирование данных с изменением формата ячеек (Макросы/Sub)
Перенос/копирование данных с изменением формата ячеек
hathory Дата: Четверг, 26.01.2017, 12:46 | Сообщение № 1
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
Доброе время суток, господа!
Хотелось бы попросить помощи вот в каком вопросе:
Есть "выгрузка" в excel из сторонней бызы данных на foxpro, выгрузка кривая, реализованная через кучу костылей, имя выгрузки каждый раз новое, база присваивает его исходя из даты, фазы луны, календаря майя и тд.
В этом же каталоге есть Модуль.exlsm, в котором идут расчеты на основании этой выгрузки, перенос данных из выгрузки в модуль я реализовал через ВПР()*1, так как в выгрузке, числа почему-то определяются как текст.
Пока я работал с расчетами, то имя новой выгрузки менял вручную, но сейчас я увольняюсь, на мое место придет другой человек, который не очень хорошо знаком с excel, и что бы автоматизировать процесс я увидел 2 варианта:
1. Подготовить макрос который сам будет переносить данные, в принципе реализовать не сложно:
[vba]
Код
Sub ()
......
Range("D7:S1008").Select 'диапазон из выгрузки'
Selection.Copy
Range("D7").Select
ActiveSheet.Paste

End Sub
[/vba]
но я не знаю как обратиться к "выгрузке", которая располагается в том же каталоге, и как присвоить формат ячеек "числовой"

2. Подготовить макрос, который будет по нажатию кнопки переименовывать "выгрузку" в заданное имя
Тут я вообще не знаю что делать.
Буду благодарен за любую помощь.


hathory

Сообщение отредактировал hathory - Четверг, 26.01.2017, 13:40
 
Ответить
СообщениеДоброе время суток, господа!
Хотелось бы попросить помощи вот в каком вопросе:
Есть "выгрузка" в excel из сторонней бызы данных на foxpro, выгрузка кривая, реализованная через кучу костылей, имя выгрузки каждый раз новое, база присваивает его исходя из даты, фазы луны, календаря майя и тд.
В этом же каталоге есть Модуль.exlsm, в котором идут расчеты на основании этой выгрузки, перенос данных из выгрузки в модуль я реализовал через ВПР()*1, так как в выгрузке, числа почему-то определяются как текст.
Пока я работал с расчетами, то имя новой выгрузки менял вручную, но сейчас я увольняюсь, на мое место придет другой человек, который не очень хорошо знаком с excel, и что бы автоматизировать процесс я увидел 2 варианта:
1. Подготовить макрос который сам будет переносить данные, в принципе реализовать не сложно:
[vba]
Код
Sub ()
......
Range("D7:S1008").Select 'диапазон из выгрузки'
Selection.Copy
Range("D7").Select
ActiveSheet.Paste

End Sub
[/vba]
но я не знаю как обратиться к "выгрузке", которая располагается в том же каталоге, и как присвоить формат ячеек "числовой"

2. Подготовить макрос, который будет по нажатию кнопки переименовывать "выгрузку" в заданное имя
Тут я вообще не знаю что делать.
Буду благодарен за любую помощь.

Автор - hathory
Дата добавления - 26.01.2017 в 12:46
Pelena Дата: Четверг, 26.01.2017, 13:21 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 19184
Репутация: 4420 ±
Замечаний: ±

Excel 365 & Mac Excel
hathory, оформите код тегами (кнопка #)


"Черт возьми, Холмс! Но как??!!"
Ю-money 41001765434816
 
Ответить
Сообщениеhathory, оформите код тегами (кнопка #)

Автор - Pelena
Дата добавления - 26.01.2017 в 13:21
K-SerJC Дата: Четверг, 26.01.2017, 13:39 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 86 ±
Замечаний: 0% ±

Excel 2013
[offtop] святой человек!
я увольняясь еще и постирал бы все что для своего удобства накодил...


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщение[offtop] святой человек!
я увольняясь еще и постирал бы все что для своего удобства накодил...

Автор - K-SerJC
Дата добавления - 26.01.2017 в 13:39
hathory Дата: Четверг, 26.01.2017, 13:44 | Сообщение № 4
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
K-SerJC, А смысл?


hathory
 
Ответить
СообщениеK-SerJC, А смысл?

Автор - hathory
Дата добавления - 26.01.2017 в 13:44
K-SerJC Дата: Четверг, 26.01.2017, 14:02 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 86 ±
Замечаний: 0% ±

Excel 2013
hathory, чтобы халява врагу не досталась :-)

если по теме, работа с файлами из каталога (функции не мои, нашел в инете):
[vba]
Код

Dim t As Integer, k As Integer, str As String, tek As Integer, rWB As Workbook, rSh As String, numsRow As Collection, f As Integer
Rpath = InputBox("где лежат файлы *.xls", "Укажите путь!", ActiveWorkbook.Path & "\01")
Texcel = ActiveWorkbook.Name
rSh = ActiveSheet.Name
tek = Workbooks(Texcel).Sheets(rSh).Cells(1, 17).Value
Set DirFile = FilenamesCollection(Rpath, "*.xls", 1) ' составим список файлов для исходных данных
If DirFile.Count < 1 Then MsgBox "в указаной папке отсутсвуют файлы *.xls", vbCritical, "Ошибка!!!": Exit Sub
For k = 1 To DirFile.Count
Set rWB = Workbooks.Open(DirFile(k)) ' открываем файлы по порядку
next k
end sub

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

[/vba]


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщениеhathory, чтобы халява врагу не досталась :-)

если по теме, работа с файлами из каталога (функции не мои, нашел в инете):
[vba]
Код

Dim t As Integer, k As Integer, str As String, tek As Integer, rWB As Workbook, rSh As String, numsRow As Collection, f As Integer
Rpath = InputBox("где лежат файлы *.xls", "Укажите путь!", ActiveWorkbook.Path & "\01")
Texcel = ActiveWorkbook.Name
rSh = ActiveSheet.Name
tek = Workbooks(Texcel).Sheets(rSh).Cells(1, 17).Value
Set DirFile = FilenamesCollection(Rpath, "*.xls", 1) ' составим список файлов для исходных данных
If DirFile.Count < 1 Then MsgBox "в указаной папке отсутсвуют файлы *.xls", vbCritical, "Ошибка!!!": Exit Sub
For k = 1 To DirFile.Count
Set rWB = Workbooks.Open(DirFile(k)) ' открываем файлы по порядку
next k
end sub

Function FilenamesCollection(ByVal FolderPath As String, Optional ByVal Mask As String = "", _
                             Optional ByVal SearchDeep As Long = 999) As Collection
    ' Получает в качестве параметра путь к папке FolderPath,
    ' маску имени искомых файлов Mask (будут отобраны только файлы с такой маской/расширением)
    ' и глубину поиска SearchDeep в подпапках (если SearchDeep=1, то подпапки не просматриваются).
    ' Возвращает коллекцию, содержащую полные пути найденных файлов
    ' (применяется рекурсивный вызов процедуры GetAllFileNamesUsingFSO)

    Set FilenamesCollection = New Collection    ' создаём пустую коллекцию
    Set FSO = CreateObject("Scripting.FileSystemObject")    ' создаём экземпляр FileSystemObject
    GetAllFileNamesUsingFSO FolderPath, Mask, FSO, FilenamesCollection, SearchDeep ' поиск
    Set FSO = Nothing: Application.StatusBar = False    ' очистка строки состояния Excel
End Function
Function GetAllFileNamesUsingFSO(ByVal FolderPath As String, ByVal Mask As String, ByRef FSO, _
                    ByRef FileNamesColl As Collection, ByVal SearchDeep As Long)
    ' перебирает все файлы и подпапки в папке FolderPath, используя объект FSO
    ' перебор папок осуществляется в том случае, если SearchDeep > 1
    ' добавляет пути найденных файлов в коллекцию FileNamesColl
    On Error Resume Next: Set curfold = FSO.GetFolder(FolderPath)
    If Not curfold Is Nothing Then    ' если удалось получить доступ к папке

        ' раскомментируйте эту строку для вывода пути к просматриваемой
        ' в текущий момент папке в строку состояния Excel
        ' Application.StatusBar = "Поиск в папке: " & FolderPath

        For Each fil In curfold.Files    ' перебираем все файлы в папке FolderPath
            If fil.Name Like "*" & Mask Then FileNamesColl.Add fil.Path
        Next
        SearchDeep = SearchDeep - 1    ' уменьшаем глубину поиска в подпапках
        If SearchDeep Then    ' если надо искать глубже
            For Each sfol In curfold.SubFolders    ' перебираем все подпапки в папке FolderPath
                GetAllFileNamesUsingFSO sfol.Path, Mask, FSO, FileNamesColl, SearchDeep
            Next
        End If
        Set fil = Nothing: Set curfold = Nothing    ' очищаем переменные
    End If
End Function

[/vba]

Автор - K-SerJC
Дата добавления - 26.01.2017 в 14:02
hathory Дата: Четверг, 26.01.2017, 14:06 | Сообщение № 6
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
K-SerJC, спасибо, но Rpath не подойдет, каталог будут, скорее всего, перемещать, нужно что бы поиск велся в том каталоге где лежит Модуль, и не бился полный путь...


hathory

Сообщение отредактировал hathory - Четверг, 26.01.2017, 14:14
 
Ответить
СообщениеK-SerJC, спасибо, но Rpath не подойдет, каталог будут, скорее всего, перемещать, нужно что бы поиск велся в том каталоге где лежит Модуль, и не бился полный путь...

Автор - hathory
Дата добавления - 26.01.2017 в 14:06
K-SerJC Дата: Четверг, 26.01.2017, 14:18 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 487
Репутация: 86 ±
Замечаний: 0% ±

Excel 2013
K-SerJC, спасибо, но Rpath не подойдет, каталог будут, скорее всего, перемещать, нужно что бы поиск велся в том каталоге где лежит Модуль, и не бился полный путь...


меняете
[vba]
Код
Rpath =  ActiveWorkbook.Path
[/vba]
и нет проблем


Благими намерениями выстелена дорога в АД.
 
Ответить
Сообщение
K-SerJC, спасибо, но Rpath не подойдет, каталог будут, скорее всего, перемещать, нужно что бы поиск велся в том каталоге где лежит Модуль, и не бился полный путь...


меняете
[vba]
Код
Rpath =  ActiveWorkbook.Path
[/vba]
и нет проблем

Автор - K-SerJC
Дата добавления - 26.01.2017 в 14:18
hathory Дата: Четверг, 26.01.2017, 14:24 | Сообщение № 8
Группа: Пользователи
Ранг: Новичок
Сообщений: 14
Репутация: 0 ±
Замечаний: 0% ±

Excel 2010
K-SerJC, Воооо, спасибо, то что нужно... Буду пробовать.


hathory

Сообщение отредактировал hathory - Четверг, 26.01.2017, 14:25
 
Ответить
СообщениеK-SerJC, Воооо, спасибо, то что нужно... Буду пробовать.

Автор - hathory
Дата добавления - 26.01.2017 в 14:24
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Перенос/копирование данных с изменением формата ячеек (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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