Страницы: 1
RSS
Выбор из таблиц значений в зависимости от номера строки
 
Здравствуйте! Помогите пожалуйста:
Имеется таблица в 4 столбца и 481 строка (А1-D481).
Необходимо создать еще 1 таблицу, в которой будут значения из первой таблицы:
A1 B1 C1D1
A11 B11 C11 D11
A21 B21 C21 D21
... ... ......
A481 B481 C481 D481
Как это можно осуществить?
Изменено: FCLM36 - 22.05.2017 13:50:12
 
Код
Sub test()
Dim i&, j&, h&, m&
Dim arr()
i = Cells(Rows.Count, 1).End(xlUp).Row
For j = 1 To i Step 10
    h = h + 1
    ReDim Preserve arr(1 To 4, 1 To h)
    For m = 1 To 4
        arr(m, h) = Cells(j, m)
    Next m
Next j
arr = Application.Transpose(arr)
Range("k1").Resize(UBound(arr, 1), UBound(arr, 2)).Value = arr
End Sub
Изменено: Nordheim - 22.05.2017 13:59:32
"Все гениальное просто, а все простое гениально!!!"
 
Большое спасибо! Помогло!
 
Для ознакомления с возможностями VBA, VBA Excel.
Еще несколько способов копирования данных (таблиц и т.д.). Процедура написана под ваш пример сделать копию таблицы.
Код
Sub TempCopy()
Dim objTemp As Object
Dim maxRow As Long, maxClmn As Long

With ThisWorkbook
  With Sheets("Лист1")
    ''' Вариант 1
    Set objTemp = .Range(.Cells(1, 1).End(xlToRight), .Cells(Rows.Count, 1).End(xlUp))
    maxRow = objTemp.Rows.Count
    maxClmn = objTemp.Columns.Count
    objTemp.Copy
'    1.1
    .Paste (.Range(.Cells(1, (maxClmn * 2) + 2), .Cells(maxRow, (maxClmn * 2) + 2)))
'    1.2
    .Paste (Sheets("Лист2").Range(Sheets("Лист2").Cells(1, 1), Sheets("Лист2").Cells(maxRow, 1)))
    Set objTemp = Nothing
    
    ''' Вариант 2 - Выгружаем (копия массива) данные на лист
    Dim arr
    arr = .Range(.Cells(1, 1).End(xlToRight), .Cells(Rows.Count, 1).End(xlUp)).Value
'    2.1
     With Sheets("Лист3")
       .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
     End With
'     2.2
     Worksheets.Add.Name = "List12345"
     With Sheets("List12345")
       .Range("A1").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
     End With
    Erase arr
  End With
End With
End Sub


 
Уважаемый TSN, дело в том что там не просто копирование таблицы, а каждой 11 строки в новую таблицу.
Если бы просто копировать полностью всю таблицу то можно так:
Код
Sub CopyTest()
Sheets("Лист1").UsedRange.Copy Sheets("Лист2").Range("a1")
End Sub
Изменено: Nordheim - 22.05.2017 15:23:05
"Все гениальное просто, а все простое гениально!!!"
 

Сори недосмотрел  :)

Все равно предложу альтернативу  ;)

Дело в том, что ReDim Preserve arr(1 To 4, 1 To h) внутри цикла замедляет выполнение процедуры. Для быстродействия лучше вычислить размер итогового массива до цикла (конечно если это возможно), так будет быстрей работать, конечно при цикле в 491 строку и 4 поля это незаметно, но если запустить обработку скажем 900000 строк и 25 полей массива ReDim Preserve однозначно проявит себя. 8)

Код
Option Explicit

Sub TempCopy11()
Dim arr(), arrItog()
Dim maxRow As Long, maxClmn As Long
Dim i As Long, x As Long, n As Long

With ThisWorkbook
    ''' Загрузка массива с шагом в 10 строк
    arr = .Sheets("Лист1").Range(.Sheets("Лист1").Cells(1, 1).End(xlToRight), .Sheets("Лист1").Cells(Rows.Count, 1).End(xlUp)).Value
    maxRow = UBound(arr, 1): maxClmn = UBound(arr, 2)
    ReDim arrItog(1 To maxRow / 10 + 1, 1 To maxClmn)
    
    For i = 1 To maxRow Step 10
    n = n + 1
      For x = 1 To maxClmn
         arrItog(n, x) = arr(i, x)
      Next x
    Next i
    
    ''' Выгрузка массива ответа в два разных места
    With Sheets("Лист2")
      .Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
    End With
    On Error Resume Next
    .Worksheets.Add.Name = "List12345"
    With Sheets("List12345")
      .Range("A1").Resize(UBound(arrItog, 1), UBound(arrItog, 2)) = arrItog
    End With
    Erase arr: Erase arrItog
End With
End Sub
 
SQL запрос, скопировать файл в С:\1\, ПКМ - обновить
Неизлечимых болезней нет, есть неизлечимые люди.
 
TSN, Полностью согласен с тем что при динамическом массиве на огромном количестве строк будет работать медленнее .
Дело в том , что речь шла не об огромном файле изначально вот я и набросал на скорую руку этот вариант :)
Изменено: Nordheim - 22.05.2017 19:36:57
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Наверх