Добрый вечер всем! Уважаемые форумчане помогите подредактировать макрос который нашел в сети, он меня устраивает но, суть такова необходимо что бы макрос собирал данные проходя по столбцам а не по строкам. то есть данный макрос вставляет данные по ячейкам A1, B1, C1 и тд. а нужно что бы он вставлял данные по очередности с ячеек A1, A2,A3.....B1, B2, B3 и тд. (Макрос работает так что нужно выделить требуемый диапазон и он вставит данные в Лист2) Заранее всем спасибо.
Добрый вечер всем! Уважаемые форумчане помогите подредактировать макрос который нашел в сети, он меня устраивает но, суть такова необходимо что бы макрос собирал данные проходя по столбцам а не по строкам. то есть данный макрос вставляет данные по ячейкам A1, B1, C1 и тд. а нужно что бы он вставлял данные по очередности с ячеек A1, A2,A3.....B1, B2, B3 и тд. (Макрос работает так что нужно выделить требуемый диапазон и он вставит данные в Лист2) Заранее всем спасибо.baaur
Sub tt() Dim rng As Range, i&, j&, r& Set rng = Selection With Sheets(2) For i = 1 To rng.Columns.Count For j = 1 To rng.Rows.Count If rng(j, i) <> "" Then r = r + 1: .Cells(r, 1) = rng(j, i) Next j Next i End With End Sub
[/vba]
попробуйте так: [vba]
Код
Sub tt() Dim rng As Range, i&, j&, r& Set rng = Selection With Sheets(2) For i = 1 To rng.Columns.Count For j = 1 To rng.Rows.Count If rng(j, i) <> "" Then r = r + 1: .Cells(r, 1) = rng(j, i) Next j Next i End With End Sub
Sub tt() r = 1 With Sheets(2) For i = Selection.Column To Selection.Column + Selection.Columns.Count For j = Selection.Row To Selection.Row + Selection.Rows.Count If Selection.Cells(j, i) <> "" Then .Cells(r, 1) = Selection.Cells(j, i) r = r + 1 End If Next j Next i End With End Sub
[/vba]
Модно проще, наверно, но я еще только учус ))
Как то так [vba]
Код
Sub tt() r = 1 With Sheets(2) For i = Selection.Column To Selection.Column + Selection.Columns.Count For j = Selection.Row To Selection.Row + Selection.Rows.Count If Selection.Cells(j, i) <> "" Then .Cells(r, 1) = Selection.Cells(j, i) r = r + 1 End If Next j Next i End With End Sub
[/vba]
Модно проще, наверно, но я еще только учус ))Tachkin
Sub qq() Dim r As Range, k& '(as long) With Sheets(2) For Each r In Selection.Columns .Cells(.Rows.Count, "H").End(xlUp).Offset(k).Resize(r.Rows.Count) = r.Value k = 1 Next End With End Sub
[/vba]
[vba]
Код
Sub qq() Dim r As Range, k& '(as long) With Sheets(2) For Each r In Selection.Columns .Cells(.Rows.Count, "H").End(xlUp).Offset(k).Resize(r.Rows.Count) = r.Value k = 1 Next End With End Sub
Sub qttq() Dim r As Range, k&, sn_, sn1_ ' Application.ScreenUpdating = 0 sn_ = ActiveSheet.Name sn1_ = Sheets.Add(, ActiveSheet).Name Sheets(sn_).Activate With Sheets(sn1_) For Each r In Selection.Columns .Cells(.Rows.Count, "H").End(xlUp).Offset(k).Resize(r.Rows.Count) = r.Value k = 1 Next End With ' Application.ScreenUpdating = 1 End Sub
[/vba]
Так нужно? [vba]
Код
Sub qttq() Dim r As Range, k&, sn_, sn1_ ' Application.ScreenUpdating = 0 sn_ = ActiveSheet.Name sn1_ = Sheets.Add(, ActiveSheet).Name Sheets(sn_).Activate With Sheets(sn1_) For Each r In Selection.Columns .Cells(.Rows.Count, "H").End(xlUp).Offset(k).Resize(r.Rows.Count) = r.Value k = 1 Next End With ' Application.ScreenUpdating = 1 End Sub
Вход
Регистрация
Напомнить пароль
Автосумма
Часто используемые
ВПР
ЕСЛИ
СУММЕСЛИ
Финансовые
Логические
Текстовые
Даты и времени 
Ссылки и массивы 
Математические
Другие функции
Проверка свойств и значений
Баз данных
Математические
Обработки массивов
Обработки строк
Преобразования типов данных 
Загрузки данных
Работы с файлами
Обработки системных параметров
Обработки цвета
Работы с датами и временем
Преобразования в системы счисления
Финансовые
