ReSQL.ru
     
powered by simpleCommunicator - 2.0.61     © 2026 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Как обычно: перетаскивнаие ячеек
19 сообщений из 69, страница 3 из 3
  3  все
Как обычно: перетаскивнаие ячеек
    #34779578
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Добавил модуль для переимнования и перемещения файлов, смотри RenameReplaceFile(replaceFile As file)
По поводу GetRange - нужно могу переделать. только зачем?

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("C:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("C:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile)
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
     ' следующая после последней строка на сводном листе
     lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
     ' заполнение этой строки значениями из очередной книги
     ' слева указываешь столбцы из сводного листа
     ' справа указываешь адресс ячейки которую нужно перенести в данный столбец
        .Range("C" & lastRow).Value = GetCel(fpath, fname, sh, "A1")
        .Range("D" & lastRow).Value = GetCel(fpath, fname, sh, "A2")
        .Range("E" & lastRow).Value = GetCel(fpath, fname, sh, "A3")
        ' /// и т.д.
        
    End With
        
End Sub

Sub RenameReplaceFile(replaceFile As file)
 Dim n
 Dim pathForReplace As String
 Dim tipeFile As String, nameMinusTipe As String
  
  ' путь для перемещения файлов
  pathForReplace = "C:\test\Base\"
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub
' Функция получающая одну ячейку из закрытой книги
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Private Function GetCel(fpath, fname, sh, rngStr)
  Dim formulaStr As String
    formulaStr = "'" & fpath & "[" & fname & "]" & sh & "'!" & Range(rngStr).Address(, , xlR1C1)
    Debug.Print formulaStr
    GetCel = ExecuteExcel4Macro(formulaStr)
End Function
...
Рейтинг: 0 / 0
06.09.2007, 01:14
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34779991
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Вариант с GetRange

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
92.
93.
94.
95.
Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile)
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
        ' следующая после последней строка на сводном листе
        lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
        ' заполнение этой строки значениями из очередной книги
        Call GetRange(fpath, fname, sh, "A1", .Range("C" & lastRow))
        Call GetRange(fpath, fname, sh, "A2", .Range("D" & lastRow))
        Call GetRange(fpath, fname, sh, "A3", .Range("E" & lastRow))
        ' /// и т.д.
    End With
        
End Sub

' Процедура, получающая диапазон из закрытой книги, можно сразу диапазоны доставать,
'  но при этом из исходного диаапазона будет скопирован диапазон такого же размра (по высоте и ширене)
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                 Range(SourceRange).Columns.Count)
'Add formula links to the closed file
With DestRange
  .FormulaArray = "='" & FilePath & "[" & FileName & "]" & SheetName & "'!" & SourceRange
  'Make values from the formulas
  .Value = .Value
End With
End Sub

Sub RenameReplaceFile(replaceFile As file)
 Dim n
 Dim pathForReplace As String
 Dim tipeFile As String, nameMinusTipe As String
  
  ' путь для перемещения файлов
  pathForReplace = "Y:\test\Base\"
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub
...
Рейтинг: 0 / 0
06.09.2007, 10:31
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34780001
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
DeggasadПо поводу GetRange - нужно могу переделать. только зачем?

поскольку упращает работу, хотя и будет дольше втягиваться в Базу....я вчера попытался, но все-таки он у меня выдает ССЫЛКА..... буду дальше еще пробывать...как-раз сейчас смотрю на перемещение+переименование....попробую въехать
...
Рейтинг: 0 / 0
06.09.2007, 10:34
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34780042
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Поправил Перемещение + Переименование
Вариант с GetCel

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
Dim svod As Workbook
Dim fso As New FileSystemObject

Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile, "Y:\test\Base\")
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
     ' следующая после последней строка на сводном листе
     lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
     ' заполнение этой строки значениями из очередной книги
     ' слева указываешь столбцы из сводного листа
     ' справа указываешь адресс ячейки которую нужно перенести в данный столбец
        .Range("C" & lastRow).Value = GetCel(fpath, fname, sh, "A1")
        .Range("D" & lastRow).Value = GetCel(fpath, fname, sh, "A2")
        .Range("E" & lastRow).Value = GetCel(fpath, fname, sh, "A3")
        ' /// и т.д.
    End With
    
End Sub

' Функция получающая одну ячейку из закрытой книги
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Private Function GetCel(fpath, fname, sh, rngStr)
  Dim formulaStr As String
    formulaStr = "'" & fpath & "[" & fname & "]" & sh & "'!" & Range(rngStr).Address(, , xlR1C1)
    GetCel = ExecuteExcel4Macro(formulaStr)
End Function

Sub RenameReplaceFile(replaceFile As file, pathForReplace As String)
 Dim n, tipeFile As String, nameMinusTipe As String
  
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub

Вариант с GetRange

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
91.
Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile.Path)
     Call RenameReplaceFile(iFile, "Y:\test\Base\")
   End If
 Next
End Sub


Sub ОбработчикФайла(foolpathFile As String)

 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = Split(foolpathFile, "\")(UBound(Split(foolpathFile, "\")))
    ' путь к исходному файлу
    fpath = Left(foolpathFile, Len(foolpathFile) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
        ' следующая после последней строка на сводном листе
        lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
        ' заполнение этой строки значениями из очередной книги
        Call GetRange(fpath, fname, sh, "A1", .Range("C" & lastRow))
        Call GetRange(fpath, fname, sh, "A2", .Range("D" & lastRow))
        Call GetRange(fpath, fname, sh, "A3", .Range("E" & lastRow))
        ' /// и т.д.
    End With
        
End Sub

' Процедура, получающая диапазон из закрытой книги, можно сразу диапазоны доставать,
'  но при этом из исходного диаапазона будет скопирован диапазон такого же размра (по высоте и ширене)
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                 Range(SourceRange).Columns.Count)
'Add formula links to the closed file
With DestRange
  .FormulaArray = "='" & FilePath & "[" & FileName & "]" & SheetName & "'!" & SourceRange
  'Make values from the formulas
  .Value = .Value
End With
End Sub

Sub RenameReplaceFile(replaceFile As file, pathForReplace As String)
 Dim n, tipeFile As String, nameMinusTipe As String
  
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub
...
Рейтинг: 0 / 0
06.09.2007, 10:42
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34781809
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
чет он не хочет заходить на фтп. Может в скрипте с GetRange надо где-то указать же сам доступ до фтп? Я его указываю в этих строках и мне выдает что путь не верен.... пытался менять ВыбратьКаталогПодкаталогиFSO fso.GetFolder на что-то похожее от GetRange но не получается.

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("фтп://логин:пароль@айпи/пакпи/папки")

 ''''''' и т.д.
End Sub

А вот когда тупо вставлю этот скрипт в пустой лист, то спокойно идет на фтп и все работает

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)

Dim Start

'Go to the destination range
Application.Goto DestRange

'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
Range(SourceRange).Columns.Count)

'Add formula links to the closed file
With DestRange
.FormulaArray = "='" & FilePath & "/[" & FileName & "]" & SheetName _
& "'!" & SourceRange

'Wait
Start = Timer
Do While Timer < Start +  2 
DoEvents
Loop

'Make values from the formulas
.Copy
.PasteSpecial xlPasteValues
.Cells( 1 ).Select
Application.CutCopyMode = False
End With
End Sub
Private Sub CommandButton1_Click()
Application.ScreenUpdating = True
On Error Resume Next

'Call the macro GetRange
GetRange "ftp://Individualnie/", "algorutm.xls", "Карта", "H21", _
Sheets("Лист1").Range("A1")

On Error GoTo  0 
Application.ScreenUpdating = False
End Sub
...
Рейтинг: 0 / 0
06.09.2007, 15:40
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34782391
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
А так???

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
79.
80.
81.
82.
83.
84.
85.
86.
87.
88.
89.
90.
Dim svod As Workbook
Dim fso As New FileSystemObject

Sub Запуск()
' назначаем сводную книгу
Set svod = Workbooks("База.xls")
'очищаем сводный лист от старья
svod.Sheets("Лист1").Range("C10:BF65536").ClearContents
' Запускаешь процедуру перебора книг в каталоге и подкаталогах с указанием пути
' в примере для 3-х каталогов, можно добавить строк скольеко нужно и изменить путь
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test1")
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("Y:\test\test2")
 ''''''' и т.д.
End Sub

'Выбрать файлы XLS в каталоге и подкаталогах
'FileSystemObject - БИБЛИОТЕКА  Microsoft Scripting Runtime
Sub ВыбратьКаталогПодкаталогиFSO(Папка As Folder)
Dim fold As Folder, iFile As file

 For Each fold In Папка.SubFolders
   ВыбратьКаталогПодкаталогиFSO fold        'лезем в рекурсию
 Next
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile)
     Call RenameReplaceFile(iFile, "Y:\test\Base\")
   End If
 Next
End Sub


Sub ОбработчикФайла(curFile As file)
 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = curFile.Name
    ' путь к исходному файлу
    fpath = Left(curFile.Path, Len(curFile.Path) - Len(fname))
    ' Лист в исходных файлах
    sh = "Лист1"

    With svod.Sheets("Лист1")
        ' следующая после последней строка на сводном листе
        lastRow = .Cells.Find("*", , , , xlByRows, xlPrevious).Offset( 1 ).Row
        ' заполнение этой строки значениями из очередной книги
        Call GetRange(fpath, fname, sh, "A1", .Range("C" & lastRow))
        Call GetRange(fpath, fname, sh, "A2", .Range("D" & lastRow))
        Call GetRange(fpath, fname, sh, "A3", .Range("E" & lastRow))
        ' /// и т.д.
    End With
        
End Sub

' Процедура, получающая диапазон из закрытой книги, можно сразу диапазоны доставать,
'  но при этом из исходного диаапазона будет скопирован диапазон такого же размра (по высоте и ширене)
' Если возвращает #ССЫЛКА!, то скорее всего указанного листа в данной книге не существует
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                 Range(SourceRange).Columns.Count)
'Add formula links to the closed file
With DestRange
  .FormulaArray = "='" & FilePath & "[" & FileName & "]" & SheetName & "'!" & SourceRange
  'Make values from the formulas
  .Value = .Value
End With
End Sub

Sub RenameReplaceFile(replaceFile As file, pathForReplace As String)
 Dim n, tipeFile As String, nameMinusTipe As String
  
  ' расширение файла
  tipeFile = Split(replaceFile.Name, ".")(UBound(Split(replaceFile.Name, ".")))
  ' имя файла без расширения
  nameMinusTipe = Left(replaceFile.Name, Len(replaceFile.Name) - Len(tipeFile) -  1 )
   
  ' подпоб коэффициента для имени файла
  n = ""
  Do While Dir(pathForReplace & nameMinusTipe & n & "." & tipeFile) <> ""
   n = Val(n) +  1 
  Loop
    
  'переименование файла
  If Val(n) Then replaceFile.Name = nameMinusTipe & n & "." & tipeFile
  ' перемещение файла
  replaceFile.Move pathForReplace
        
End Sub
...
Рейтинг: 0 / 0
06.09.2007, 17:52
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34782663
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
  
 For Each iFile In Папка.Files
   If UCase(iFile.Name) Like "ALG*.XLS" Then
     Call ОбработчикФайла(iFile)
     Call RenameReplaceFile(iFile, "Y:\test\Base\")
   End If
 Next
End Sub
 
Sub ОбработчикФайла(curFile As file)
 Dim fname As String, fpath As String, sh As String
 Dim lastRow As Long
    ' имя исходного файла
    fname = curFile.Name
    ' путь к исходному файлу
    fpath = Left(curFile.Path, Len(curFile.Path) - Len(fname))

как я увидел ты поменял скрипт именно в этих строках, так? И все равно файл пишет ошибку 76 нет пути
...
Рейтинг: 0 / 0
06.09.2007, 19:29
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34782739
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
А если GetRange вот на это (см ниже) заменить, это плюс к предыдущим изменениям
я просто хрен знаю этот фтп, хрен его знает что ему нужно.

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
Sub GetRange(FilePath As String, FileName As String, SheetName As String, _
SourceRange As String, DestRange As Range)
'Resize the DestRange to the same size as the SourceRange
Set DestRange = DestRange.Resize(Range(SourceRange).Rows.Count, _
                                 Range(SourceRange).Columns.Count)
'Add formula links to the closed file
With DestRange
  .FormulaArray = "='" & FilePath & _
                  IIf(Right(FilePath,  1 ) = "/", "/", "") & _
                  "[" & FileName & "]" & SheetName & "'!" & SourceRange
  'Make values from the formulas
  .Value = .Value
End With
End Sub
...
Рейтинг: 0 / 0
06.09.2007, 20:10
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785204
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Чё могчишь получилось чи не?
...
Рейтинг: 0 / 0
07.09.2007, 17:06
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785245
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
DeggasadЧё могчишь получилось чи не?

сорри запарочка на работе.....та не выходит кричит что нету такого пути когда в процедуре
Код: plaintext
Sub Запуск()
я указываю
Код: plaintext
 ВыбратьКаталогПодкаталогиFSO fso.GetFolder("фтп.....")
...не знюю...щас вроде докачиваю книгу Джон Уокенбах, мож там что-то будет....а пока не хочет заходить на фтп...кстати а почем у вас пивко ;)?
...
Рейтинг: 0 / 0
07.09.2007, 17:17
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785361
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
да..Да...я скачал книгу и она открывается....вот сцылка http://ihtik.2x4.ru/complit_22janv2007/complit_22janv2007_4783.rar....тянуть надо Download Master ...удачи люди
...
Рейтинг: 0 / 0
07.09.2007, 17:48
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785459
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Хелпяда..Да...я скачал книгу и она открывается....вот сцылка http://ihtik.2x4.ru/complit_22janv2007/complit_22janv2007_4783.rar....тянуть надо Download Master ...удачи люди

Уже есть.
...
Рейтинг: 0 / 0
07.09.2007, 18:26
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785708
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Посмотрел я сегодня что есть Ваш фтп.
Ну мы с вами и понаворотили.
Ладно я глупый - никогда не сталкивался, но вы то...
Весь написанный выше код не будет работать с фтп и не пытайтесь его туды сувать .
Исключение составляет только процедура GetRange, т.к. эксель может при непосредственном введении пути в ячейки вытащить из фтп из файла данные по сцылочке, но насколько я понимаю он просто копирует файл во временную папку и оттуда уже смотрит. И вот тут уже возможны азличные глюки, которые мне лично не очень нравятся, например если файл на фтп обновить. то не факт что ссылка на него обновится. так как эксель посмотрит уже скачанный файл. Возможно этого можно избежать, я просто по любительски рассуждаю о первом впечатлении. А впечатление такое, что фтп для передачи данных может ещё и нужен если кому нравится, но чтобы работать там с ними - наверное не стоит. Скопировал к себе и тама делай что хочешь.
Но если всё же хочется на форуме есть примеры реализации некоторых функций, можно попробовать разобраться, но придётся немного больше попотеть чем над нашим макросом...
...
Рейтинг: 0 / 0
07.09.2007, 22:13
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785783
White Owl
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
White Owl
Участник
DeggasadПосмотрел я сегодня что есть Ваш фтп.
Ну мы с вами и понаворотили.А чего вы тут наворотили? Вы такой славный междусобойчик тут организовали, что я и не заглядывал в этот топик. А тут сморю уже третья страница пошла... кофе кончилось, рабочий день еще тянется...


DeggasadИсключение составляет только процедура GetRange, т.к. эксель может при непосредственном введении пути в ячейки вытащить из фтп из файла данные по сцылочке, но насколько я понимаю он просто копирует файл во временную папку и оттуда уже смотрит.Правильно понимаешь, именно во временную папку, а если еще точнее, то в Temporary Internet Files оно файлы и вытягивает.
DeggasadИ вот тут уже возможны азличные глюки, которые мне лично не очень нравятся, например если файл на фтп обновить. то не факт что ссылка на него обновится. так как эксель посмотрит уже скачанный файл.Там немножко другие механизмы. Но в теории, при правильно настроеном .... всем, при обновлении файла IE (а Эксель пользуется для работы с интеренетом кусками из IE) должен увидеть что файл обновился и выкачать его повторно. А если не обновился - возьмет из кеша.

DeggasadА впечатление такое, что фтп для передачи данных может ещё и нужен если кому нравится, но чтобы работать там с ними - наверное не стоит. Скопировал к себе и тама делай что хочешь.Неее.. с одни кофе это не расшифровать.
...
Рейтинг: 0 / 0
08.09.2007, 00:43
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34785861
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
White OwlА чего вы тут наворотили?

Да так особо и ничего. Просто сделали код для работы с папками и файлами в этих папках (с этим все нормально). Но потом я не зная что такое фтп по глупости своей пытался угадать чего это он (код) с ним не хочет работать. При этом всё что я знал про фтп - только то,что пути по разному пишутся. Ну вообщем поспешно, потом посмотрел вроде не получится как с обычными папками с фтп работать (тут опять могу быть не прав, потому как незнаю вопроса). Не буду дальше рассуждать, а то опять поспешно окажется.
...
Рейтинг: 0 / 0
08.09.2007, 09:53
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34787551
Хелпя
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Хелпя
Гость
2 Deggasad, кстати ты не ответил на один вопросик ;) вот дата 7 сен 07, 17:17 ....просомтрите ....

и по поводу фтп я тоже посидел на выходных и полистал....да все правильно там в Темп падает инфа, а поскоку Темп у нас не всегда надежен будет лучше если использовать то что было прописано ранее, т.е. локальные диски. Тогда получается что еще бы лучше сделать кнопочку для сохранение на фтп этот вопросик я поднимал на уже на форуме, но ответа врзумительного так и не получил ...http://sql.ru/forum/actualthread.aspx?tid=470912 и с темами пытлася ознакомится, но что-то толкового через посик по форуму не нашел...
...
Рейтинг: 0 / 0
10.09.2007, 11:19
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #34788249
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Хелпя2 Deggasad, кстати ты не ответил на один вопросик ;) вот дата 7 сен 07, 17:17 ....просомтрите ....

и по поводу фтп я тоже посидел на выходных и полистал....да все правильно там в Темп падает инфа, а поскоку Темп у нас не всегда надежен будет лучше если использовать то что было прописано ранее, т.е. локальные диски. Тогда получается что еще бы лучше сделать кнопочку для сохранение на фтп этот вопросик я поднимал на уже на форуме, но ответа врзумительного так и не получил ...http://sql.ru/forum/actualthread.aspx?tid=470912 и с темами пытлася ознакомится, но что-то толкового через посик по форуму не нашел...

1) Пиво у нас
Carlsberg и Tuborg Green:
- в супермаркете 27 - 28 р /0,5 л
- в ночном магазине 31 - 32 р /0,5 л
- в кабаке 50 - 80 р /0,5 л
разливное "живое":
- в супермаркете 40 - 200 р /1 л

2) Ссылку, я считаю, вам хорошую дали, вкратце посмотрел, там вроде можно дельное найти. Мне самому сейчас разбираться с фтп особо некогда (да и не особо - некогда). Если вдруг появится время обещаю посмотрю, но может кто другой кнопку решится сделать.
...
Рейтинг: 0 / 0
10.09.2007, 13:42
| Ответить | Цитировать | Написать  
Период между сообщениями больше года.
Как обычно: перетаскивнаие ячеек
    #36953254
Deggasad
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Deggasad
Участник
Случайно наткнулся на эту тему.
А пивка-то я так и не попил :(
Я особо и не расчитывал, но автор так настаивал меня им одарить
З.ы.: просто к слову пришлось какие разные люди бывают...
...
Рейтинг: 0 / 0
13.11.2010, 08:28
| Ответить | Цитировать | Написать  
Как обычно: перетаскивнаие ячеек
    #37020342
Djon Player
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Djon Player
Участник
Deggasad,

Что-ж, бывают и такие люди, сначала золотые горы предлагают, а потом...
Лучше бы ничего не предлагали.
...
Рейтинг: 0 / 0
17.12.2010, 12:17
| Ответить | Цитировать | Написать  
19 сообщений из 69, страница 3 из 3
  3  все
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Как обычно: перетаскивнаие ячеек
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение   Полит. конфиден.  
NoSQL.ru       Кролег: Проекты, Новости, Чат       РЕД ФОРУМ       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=61&msg=34780001&tid=2177345]:
 0ms
get settings:
 5ms
get forum list:
 12ms
check forum access:
 2ms
check topic access:
 2ms
track hit:
 150ms
get topic data:
 8ms
get forum data:
 1ms
get page messages:
 52ms
get tp. blocked users:
 1ms
others: 211ms
total:  444ms
созд. / загр.: 444ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]