Скопировать данные из таблицы xlsx в текущую книгу

[Dimitriusik]

У нас открыта книга с таблицей. В каталоге C:/Raports/block/ находится 1 файл в формате xlsx.
Надо из этого файла скопировать столбцы A и B в текущую открытую книгу в столбцы G и H макросом

[kuklp]

Вы жалуетесь, или хвастаетесь?

[Dimitriusik]

Сообщение от kuklp

Вы жалуетесь, или хвастаетесь?

спрашиваю. не знаю как это сделать макросом

[kuklp]

Ну извините, я вот не увидел и намека на вопрос в топике. Да и пример в файле принято выкладывать. Быстрей результат будет.

[Serge_Bliznykov]

Сообщение от Dimitriusik

как это сделать макросом

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

Sub GetColumnsFromFirstFile()
  Dim fn$, wb As Workbook, activewb As Workbook
  Const pt$ = "C:\Raports\block\"

  'Отключаем обновление экрана
  Application.ScreenUpdating = False
  Application.DisplayAlerts = 0

  fn = Dir(pt & "*.xlsx")
  If fn = "" Then
     MsgBox "Not Found xlsx Files in catalog " & pt
  Else

    Set activewb = ActiveWorkbook
    Set wb = Workbooks.Open(pt & fn)

    wb.Worksheets(1).Range("A:B").Copy _
         Destination:=activewb.ActiveSheet.Range("G:H")
    wb.Close
 
    MsgBox "Get data from " & fn

  End If


  Application.DisplayAlerts = 1
  'Включаем обновление экрана
  Application.ScreenUpdating = True

End Sub

[Dimitriusik]

Сообщение от Serge_Bliznykov

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

Sub GetColumnsFromFirstFile()
  Dim fn$, wb As Workbook, activewb As Workbook
  Const pt$ = "C:\Raports\block\"

  'Отключаем обновление экрана
  Application.ScreenUpdating = False
  Application.DisplayAlerts = 0

  fn = Dir(pt & "*.xlsx")
  If fn = "" Then
     MsgBox "Not Found xlsx Files in catalog " & pt
  Else

    Set activewb = ActiveWorkbook
    Set wb = Workbooks.Open(pt & fn)

    wb.Worksheets(1).Range("A:B").Copy _
         Destination:=activewb.ActiveSheet.Range("G:H")
    wb.Close
 
    MsgBox "Get data from " & fn

  End If


  Application.DisplayAlerts = 1
  'Включаем обновление экрана
  Application.ScreenUpdating = True

End Sub

Круто! Большое спасибо!