Гость
Войти | Профиль | Очистить
Целевая тема:
Создать новую тему:
Автор:
Действия ...
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос по копированию / 8 сообщений из 8, страница 1 из 1
20.02.2007, 09:48:39
    #34342874
@ntony
@ntony
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
Доброго всем времени суток, есть проблема, в прикрепленном файле есть образец информации, нужно, чтобы макрос копировал данные на другой лист и при этом, пропуская пустые строки (таковых в данных встречается много, причем они могут быть и по две сразу) и заполняя значения Product Name одинаковыми до последующего. Заранее благодарен. (может это и просто, но я в ВБА исчо новичок ))))
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 11:51:59
    #34343311
vkodor
vkodor
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
Sub f()
    Dim rng As Range, rng2 As Range, rng3 As Range, i As Long
    Set rng = Cells.Find(What:="Product Name",  LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=True)
    If rng Is Nothing Then Exit Sub
    For i = rng.Row +  1  To Worksheets(rng.Parent.Name).UsedRange.Rows.Count
        If Cells(i, rng.Column) = "" And Cells(i, rng.Column +  1 ) = "" Then
            If rng2 Is Nothing Then
                Set rng2 = Cells(i, rng.Column)
            Else
                Set rng2 = Union(rng2, Cells(i, rng.Column))
            End If
        ElseIf Cells(i, rng.Column) = "" Then
            Cells(i, rng.Column) = rng3
        Else
            Set rng3 = Cells(i, rng.Column)
        End If
    Next
    rng2.EntireRow.Delete
End Sub
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 12:00:19
    #34343358
@ntony
@ntony
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
5 Баллов, огромное спс ))))
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 12:05:13
    #34343387
vbapro
vbapro
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
2vkodor
не критика, просто для удобства :-) :
Код: plaintext
Worksheets(rng.Parent.Name)=rng.Worksheet
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 12:33:15
    #34343484
vkodor
vkodor
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
vbapro2vkodor
не критика, просто для удобства :-) :
Код: plaintext
Worksheets(rng.Parent.Name)=rng.Worksheet

Спасибо.
Не знал.
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 17:03:11
    #34344683
KL (XL)
KL (XL)
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
Еще вариант без циклов (до 8.192 несмежных областей)

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
Sub Test()
    Dim rng As Range
    Set rng = Worksheets.Add(, Worksheets("Sheet1")).[A1]
    With Worksheets("Sheet1")
        Intersect(.[A:B], .[B:B].SpecialCells(xlCellTypeConstants).EntireRow).Copy rng
    End With
    With rng.CurrentRegion.SpecialCells(xlCellTypeBlanks)
        .Value = "=R[-1]C"
        .Value = .Value
    End With
End Sub


KL
[MVP - Microsoft Excel]
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
20.02.2007, 17:48:09
    #34344876
vkodor
vkodor
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
KL (XL)Еще вариант без циклов (до 8.192 несмежных областей)

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
Sub Test()
    Dim rng As Range
    Set rng = Worksheets.Add(, Worksheets("Sheet1")).[A1]
    With Worksheets("Sheet1")
        Intersect(.[A:B], .[B:B].SpecialCells(xlCellTypeConstants).EntireRow).Copy rng
    End With
    With rng.CurrentRegion.SpecialCells(xlCellTypeBlanks)
        .Value = "=R[-1]C"
        .Value = .Value
    End With
End Sub


KL
[MVP - Microsoft Excel]
класный вариант
только строка
Код: plaintext
        .Value = .Value
не правильно отрабатывает
во все ячейки с формулами, вставляется значение первой ячейки. (Excel2000 SP3)
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
21.02.2007, 00:09:40
    #34345448
KL (XL)
KL (XL)
Участник
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Макрос по копированию
vkodorтолько строка
Код: plaintext
        .Value = .Value
не правильно отрабатывает
во все ячейки с формулами, вставляется значение первой ячейки. (Excel2000 SP3)

Точно, спасибо за поправку. Код должен быть таким:

Код: plaintext
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
Sub Test()
    Dim rng As Range
    Set rng = Worksheets.Add(, Worksheets("Sheet1")).[A1]
    On Error Resume Next
    With Worksheets("Sheet1")
        Intersect(.[A:B], .[B:B].SpecialCells(xlCellTypeConstants).EntireRow).Copy rng
    End With
    With rng.CurrentRegion
        .SpecialCells(xlCellTypeBlanks).Value = "=R[-1]C"
        .Value = .Value
    End With
End Sub
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
Форумы / Microsoft Office [игнор отключен] [закрыт для гостей] / Макрос по копированию / 8 сообщений из 8, страница 1 из 1
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение  
Полит. конфиден.  
созд. / загр.: 354ms
Закрыть
start [/forum/topic.php?fid=61&mobile=1&tid=2183405]:
 0ms
get settings:
 7ms
get forum list:
 24ms
check forum access:
 3ms
check topic access:
 3ms
track hit:
 62ms
get topic data:
 6ms
get forum data:
 2ms
get page messages:
 43ms
get tp. blocked users:
 1ms
others: 203ms
total:  354ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]