копирование данных в новую таблицу при интерактивном выборе файла

[gege]

Ребят, тут такая запара:
Нужно создать макрос, с помошью которого юзер выбирал какую то таблицу эксель, и после его выбора автоматом создавалась новая таблица с данными выбранной, но в немного видоизмененном виде.
Сам я в принципе VBA никогда не касался, но начальник сказал "надо". так что не судите строго
Я сделал в экселе кнопку, по которой вылезает меню выбора файла, после выбора файл открывается:

Private Sub OpenFile_Click()

Dim lngCount As Long

' Open the file dialog
With Application.FileDialog(msoFileDialo gOpen)
.AllowMultiSelect = True
.Show

' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
NameFile = .SelectedItems(lngCount)
Next lngCount

Workbooks.Open NameFile

End Sub

(может и файл то откывать не стоит,хз)
А вот дальше хуже..
Не знаю, как правильно из этого файла скопировать данные в новую таблицу эксель.
Подскажите, плиз.

[EducatedFool]

Без исходного файла сложно посоветовать что-либо конкретное.

Нужно создать макрос, с помошью которого юзер выбирал какую то таблицу эксель

В файле может быть несколько таблиц (на одном листе или на нескольких). Как юзер выбирает таблицу? Или ему достаточно выбрать только лист (или даже файл), её содержащий?

.AllowMultiSelect = True

' Display paths of each file selected
For lngCount = 1 To .SelectedItems.Count
NameFile = .SelectedItems(lngCount)
Next lngCount

Workbooks.Open NameFile

Какой смысл разрешать выбирать юзеру несколько файлов, если открываем один файл?
Или юзеру позволено выбирать сразу несколько?

после его выбора автоматом создавалась новая таблица с данными выбранной, но в немного видоизмененном виде.

Насколько должен быть изменён вид таблицы?

Желательно приложить 2 файла:
1 - исходный (один из тех, что может выбрать юзер)
2 - тот же файл, только уже после внесения нужных изменений

[gege]

.AllowMultiSelect = True
по поводу этой строки - да, нужно запретить выбирать несколько файлов, то бишь
.AllowMultiSelect = False

Юзер выбирает сохраненный лист Excel. Он может быть сохранен под любым именем и где угодно.

Из исходного файла нужно скопировать ячейки:
B6:B3500 в новый лист, книгу (значения не имеет), в ячейки A6 :А3500
C6:C3500 в В6:В3500
D6:D3500 в C6:C3500
E6:E3500 в H6:Н3500
G6:G3500 в I6:I3500
H6:H3500 в K6:К3500

[gege]

вроде бы несложно все, но что то туплю

[EducatedFool]

Вот один из способов:

Sub test()
    With Application.FileDialog(msoFileDialogOpen)    'только для MS Excel XP и старше
        .InitialFileName = "c:\"
        .FilterIndex = 3
        .AllowMultiSelect = False
        If .Show = -1 Then
            Filename = .SelectedItems(1)        ' читаем путь выбранного файла
        Else
            Exit Sub           ' отмена чтения
        End If
    End With

    Dim wb1 As Workbook, wb2 As Workbook, ra1 As Range, ra2 As Range

    Set wb1 = Workbooks.Open(Filename) ' открываем выбранный юзером файл
    If wb1 Is Nothing Then Exit Sub
    Set wb2 = Workbooks.Add ' создаём новую книгу

    Set ra1 = wb1.ActiveSheet.Range("a6:a3500")
    Set ra2 = wb2.ActiveSheet.Range("a6")

    ra1.Offset(, 1).Resize(, 3).Copy ra2 ' копируем b6:b3500 в a6:a3500, C6:C3500 в В6:В3500, D6:D3500 в C6:C3500
    ra1.Offset(, 5).Copy ra2.Offset(, 8) ' копируем E6:E3500 в H6:Н3500
    ra1.Offset(, 7).Copy ra2.Offset(, 9) ' копируем G6:G3500 в I6:I3500
    ra1.Offset(, 8).Copy ra2.Offset(, 11) ' копируем H6:H3500 в K6:К3500

    wb2.ActiveSheet.Range("a:k").Columns.AutoFit ' автоматически выставляем ширину столбцов
    wb1.Close False    ' закрываем открытую юзером книгу
End Sub

[gege]

EducatedFool, спасибо огромное!
Все здорово)
А еще не подскажете, как разлиновать таблицу до конца данных?

[gege]

Не, лучше такой вопрос: как можно сделать, чтоб столбец копировался не до конкретной ячейки, а пока в нем есть данные?

[EducatedFool]

как разлиновать таблицу до конца данных?

чтоб столбец копировался не до конкретной ячейки, а пока в нем есть данные

например, так:

Sub test2()
    Application.ScreenUpdating = False
    With Application.FileDialog(msoFileDialogOpen)   
        .InitialFileName = "c:\": .FilterIndex = 3: .AllowMultiSelect = False
        If .Show = -1 Then Filename = .SelectedItems(1) Else Exit Sub                                            
    End With

    Dim wb1 As Workbook, wb2 As Workbook, ra1 As Range, ra2 As Range, ra2used As Range

    Set wb1 = Workbooks.Open(Filename): If wb1 Is Nothing Then Exit Sub
    Set wb2 = Workbooks.Add

    Set ra1 = wb1.ActiveSheet.Range("b6", wb1.ActiveSheet.Range("b6").End(xlDown))    ' копируем только непустые ячейки
    Set ra2 = wb2.ActiveSheet.Range("a6")

    ra1.Offset(, 0).Resize(, 3).Copy ra2    
    ra1.Offset(, 4).Copy ra2.Offset(, 8)    
    ra1.Offset(, 6).Copy ra2.Offset(, 9)    
    ra1.Offset(, 7).Copy ra2.Offset(, 11)   

    Set ra2used = wb2.ActiveSheet.UsedRange    ' разлиновываем используемый диапазон листа
    With ra2used.Borders
        .LineStyle = xlContinuous: .Weight = xlThin: .ColorIndex = xlAutomatic
    End With
    ra2used.Borders(xlDiagonalDown).LineStyle = xlNone: ra2used.Borders(xlDiagonalUp).LineStyle = xlNone

    wb2.ActiveSheet.Range("a:k").Columns.AutoFit
    wb1.Close False    
    Application.ScreenUpdating = True
End Sub