Доработать макрос нарезки таблиц

[Toffifee]

Здравствуйте уважаемые программисты!!
Хотелось бы доработать макрос, который нарезает таблицу по указанному столбцу в шапке, помогите пожалуйста.

Представленный ниже файл с макросом нарезает только ту таблицу, которая есть в файле.

Нарезка таблицы по шапке.rar

А как доработать так, чтоб можно было загрузить любую таблицу и нарезать её. А не только ту, которая представленна.
Пример других таблиц, которые можно будет загружать и нарезать:
Пример 1( нарезка идет по округу).rar
Пример 2 (нарезка идет по городам).rar

[Toffifee]

Пожаааалуйста, хотя бы код загрузки других таблиц....... остальное постараюсь сама как нибудь найти..... пожааалуйста, помогите!!!!

[Toffifee]

Я нашла вот такой код, он выбор папки открывает:

Function GetFilePath(Optional ByVal Title As String = "Выберите файл для обработки", _
Optional ByVal InitialPath As String = "c:\", _
Optional ByVal FilterDescription As String = "Книги Excel", _
Optional ByVal FilterExtention As String = "*.xls*") As String
' функция выводит диалоговое окно выбора файла с заголовком Title,
' начиная обзор диска с папки InitialPath
' возвращает полный путь к выбранному файлу, или пустую строку в случае отказа от выбора
' для фильтра можно указать описание и расширение выбираемых файлов
On Error Resume Next
With Application.FileDialog(msoFileDialo gOpen)
.ButtonName = "Выбрать": .Title = Title: .InitialFileName = InitialPath
.Filters.Clear: .Filters.Add FilterDescription, FilterExtention
If .Show <> -1 Then Exit Function
GetFilePath = .SelectedItems(1): PS = Application.PathSeparator
End With
End Function

Sub ПримерИспользования_GetFilePath()
ИмяФайла = GetFilePath("Выберите файл Word", , "Документы Excel", "*.xlsx") ' запрашиваем имя файла
If ИмяФайла = "" Then Exit Sub ' выход, если пользователь отказался от выбора файла
MsgBox "Выбран файл: " & ИмяФайла, vbInformation
End Sub


Помогите пожалуйста как дописать код так чтоб он открывал найденный файл в книгу из которой макрос запущен....

[nilem]

А если так.
Берем код из старой темы и кладем его в Персонал.
Открываем нужный файл, по Alt+F8 запускаем макрос и "нарезаем".
Тот код ориентируется на CurrentRegion, т.е. не допускаются полностью пустые строки или столбцы, это надо учесть. Доработайте.

[Toffifee]

Я тоже об этом думала.... спасибо!
А как это сделать? Т.е. как положить его в Персонал?

[nilem]

Если Персонал еще нет - включаем макрорекордер, выбираем пунктик сохранить в Персональной книге макросов, пишем что-нибудь простенькое, останавливаем запись, сохраняем.
А потом в VBE просто перетаскиваем модуль в Персонал.
Там в коде есть ThisWorkBook.Path, надо изменить,например, на ActiveWorkBook.Path; иначе все сохранится в папку с Персонал.

[Hugo121]

Уточню - с коррекцией пути так нужно делать:
Сперва в начале
Dim pth$
pth = ActiveWorkbook.Path
потом в той строке
.SaveAs Filename:=pth & "\" & k & ".xlsx"

Непосредственно в той строке ActiveWorkbook.Path определять нельзя, т.к. в тот момент активна только что созданная книга.

[Toffifee]

Это поняла... теперь работает, но файлы пустыесоздает (((( ....

Option Explicit

Sub Нарезать() 'универсальный вариант
Dim r As Range, rng As Range, x, i&, c&, k$, colC As New Collection
Dim pth$
pth = ActiveWorkbook.Path
On Error Resume Next
Set r = Application.InputBox("Щелкните ячейку внутри таблицы", "Выбор столбца", _
ActiveCell.Address, Type:=8)
If r Is Nothing Then Exit Sub
Set rng = r.CurrentRegion: x = rng.Value: c = r.Column - rng.Column + 1
If MsgBox("Выбираем данные из столбца " & rng(1, c), vbYesNo, _
"Выбор столбца") = vbNo Then Exit Sub
Application.ScreenUpdating = False
If ActiveSheet.FilterMode Then ActiveSheet.ShowAllData

For i = 3 To UBound(x)
k = CStr(x(i, c))
If IsEmpty(colC.Item(k)) Then
colC.Add k, k
rng.AutoFilter Field:=c, Criteria1:=k, Operator:=xlOr, Criteria2:="="
ActiveSheet.UsedRange.SpecialCells( 12).Copy
With Workbooks.Add
With .Sheets(1)
.Paste: .Shapes(1).Delete
End With
.SaveAs Filename:=pth & "\" & k & ".xls", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
End If
Next i: rng.AutoFilter
Application.ScreenUpdating = True
End Sub

[nilem]

Вот, пробуйте. Пояснения:
На запрос "Щелкните ячейку внутри таблицы" нужно выбрать ячейку не в шапке, а внутри таблицы в том столбце, который собираемся "нарезать".
На следующий запрос "Есть ли шапка в таблице?" нужно ответить Нет, если сама таблица отделена от шапки пустой строкой, и Да, если шапка и данные составляют одно целое.
Если предыдущий ответ Да, то в следующем запросе "Сколько строк в шапке" нужно записать число строк шапки.
Макрос называется Narezka, запускаем по Alt-F8. Модуль с этим макросом можно перенести в Персонал.

[Toffifee]

У меня нет слов... одни эмоции!!!!!!!!!!
это..это просто ВАУ!!!!!!!!
СПАСИБО!!!!!!!!