Здравствуйте, помогите с задачей. Есть более 300х файлов находящихся в одной папке, которые постоянно добавляются (имена файлов 001 ИП; 002 ИП; 003 ООО; 004 АО), имеющие одинаковую структуру, в них есть несколько листов, одни лист во всех называется "Данные". Вот из этого листа нужно вытащить несколько строк (не диапазон, а только конкретные) из одного столбца и перенести в отдельный файл. Должно получиться в первой строчке данные из первого файла, во второй из второго и т. д.. Желательно что бы обновлялось, т. е. задать папку с файлами. Пробовал макрос, но он копирует только в столбцы.
vologda, Добрый день, где в файле "Исходные данные" лист с именем "Данные". По какому принципу нужно вытаскивать оттуда данные? И по какому принципу они вставляются в файл "Итоговый журнал"?
msi2102, В прикрепленном файле "Исходные данные" только один лист из него нужно вытащить ячейки B1,B2,B3,B4,B5,B8,B12,B23,B24, и вставить в "Итоговый" другом файле в ячейке А1:I1. Соответственно из последующих файлов должно встать в третью четвертую и т.д строки.
msi2102, просьба помочь отредактировать макрос. Нужно поменять выборку под три отдельные ячейки.
Менял Range и Case. Но думаю я что то не так делаю в блоке Case'ов Заранее благодарен.
Код
Sub Copy_data()
Dim FilesToOpen
Dim x As Integer
Dim a(), i As Long, b As Long
Dim lis As String
Application.ScreenUpdating = False
On Error GoTo EH
FilesToOpen = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*", MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Select files to open"
Exit Sub
End If
x = 1
While x <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
Workbooks(importWB.Name).Sheets("info").Activate
a = Workbooks(importWB.Name).Sheets("info").Range("C6,C7,H5").Value
b = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
For i = 1 To 3
Select Case i
Case 1 To 3: s = i
End Select
ThisWorkbook.Sheets("Sheet1").Cells(b, i) = a(s, 1)
Next
importWB.Close savechanges:=False
x = x + 1
Wend
Application.ScreenUpdating = True
Exit Sub
EH:
MsgBox "Info is copied"
Application.ScreenUpdating = True
End Sub
Sub Copy_data()
Dim FilesToOpen
Dim x As Integer
Dim a(), i As Long, b As Long
Dim lis As String
Application.ScreenUpdating = False
On Error GoTo EH
FilesToOpen = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*", MultiSelect:=True, Title:="Files to Merge")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "Select files to open"
Exit Sub
End If
x = 1
While x <= UBound(FilesToOpen)
Set importWB = Workbooks.Open(Filename:=FilesToOpen(x))
Workbooks(importWB.Name).Sheets("info").Activate
' a = Workbooks(importWB.Name).Sheets("info").Range("C6,C7,H5").Value
b = ThisWorkbook.Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
' For i = 1 To 3
' Select Case i
' Case 1 To 3: s = i
' End Select
ThisWorkbook.Sheets("Sheet1").Cells(b, 1) = Workbooks(importWB.Name).Sheets("info").Range("C6").Value
ThisWorkbook.Sheets("Sheet1").Cells(b, 2) = Workbooks(importWB.Name).Sheets("info").Range("C7").Value
ThisWorkbook.Sheets("Sheet1").Cells(b, 3) = Workbooks(importWB.Name).Sheets("info").Range("H5").Value
' Next
importWB.Close savechanges:=False
x = x + 1
Wend
Application.ScreenUpdating = True
Exit Sub
EH:
MsgBox "Info is copied"
Application.ScreenUpdating = True
End Sub
но без файла для которого Вы делаете, это гадание на кофейной гуще