Редизайнер таблицы, помогите с макросом.

[Mariam]

Добрый день,

Есть таблица: в первых строках наименование товара, ответственный, тип активности, периоды проведения и тд. Далее в шапке адресса и в ячейке стооят "1" там где есть активность. На отдельном листе хотелось бы увидеть списком только те данные ( наименование товара, ответственный, тип активности, периоды проведения и адресс) где есть активность, т.е. только те данные где стоят "1". Макрос в файле задачу выполняет не полностью: 1. Он не обрабатывает весь выделенные диапазон, а срабатывает отлично только если выбрать 1-ну колонку с признаком, например только "тип активности" и всю адресску. 2. Вставляет данные на новый лист с формулами, а нужно только значения. Помогите исправить макрос так, что бы он "трансформировал" всю выделенную таблицу и вставлял как значения.

Спасибо.

[psiho]

Лови готовый примерчик

[Mariam]

круто, а можешь мне код макроса скинуть, а то файл копируется с иероглифами и макроса нет в VB

[psiho]

круто, а можешь мне код макроса скинуть, а то файл копируется с иероглифами и макроса нет в VB

Лови. Не забудь макрос привязать к кнопке. И ещё-макрос завязан на имена листов и на колонки. Если будешь добавлять колонки, то нужно будет изменять значение первого столбца с адресами.

[Mariam]

Посмотри, пожалуйста, что-то я пропустила...Хотела построить под свою "рабочую" таблицу. У меня диапазон - B2:V2 в W2 уже начинаются адресса.

Вроде все поменяла, выдает ошибку out of range.

Код (vb) Выделить Развернуть

Public ПослСтрокаЛист As Long, ПослСтолбецЛист As Long, НоваяСтрока As Long

Public Function LastRowInSheet(Sh As Object)
   On Error Resume Next
   LastRowInSheet = Sh.Cells.Find(What:="*", after:=Sh.Cells(1, 1), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, _
                                  MatchCase:=False).Row
   On Error GoTo 0
End Function

Public Function LastColumnInSheet(Sh As Object)
   On Error Resume Next
   LastColumnInSheet = Sh.Cells.Find(What:="*", after:=Sh.Cells(1, 1), LookAt:=xlPart, LookIn:=xlValues, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, _
                                     MatchCase:=False).Column
   On Error GoTo 0
End Function

Sub Редизайнер()

   Application.ScreenUpdating = False
   Application.DisplayAlerts = False
   Application.EnableEvents = False
   ПослСтрокаЛист = LastRowInSheet(Worksheets("for PM"))
   ПослСтолбецЛист = LastColumnInSheet(Worksheets("for PM"))
   If ПослСтрокаЛист > 1 Then Worksheets("for PM").Range(Worksheets("for PM").Cells(2, 1), Worksheets("for PM").Cells(ПослСтрокаЛист, ПослСтолбецЛист)).Clear
   ПослСтрокаЛист = LastRowInSheet(ActiveSheet)
   ПослСтолбецЛист = LastColumnInSheet(ActiveSheet)
   For j = 19 To ПослСтолбецЛист
       Адрес = ActiveSheet.Cells(1, j).Value
       For i = 2 To ПослСтрокаЛист
           If Cells(i, j).Value = 1 Then
               Range(Cells(i, 1), Cells(i, 21)).Copy
               Worksheets("for PM").Activate
               НоваяСтрока = LastRowInSheet(ActiveSheet) + 1
               Range(Cells(НоваяСтрока, 1), Cells(НоваяСтрока, 21)).PasteSpecial (xlPasteValues)
               Cells(НоваяСтрока, 22).Value = Адрес
               Worksheets("Status").Activate
           End If
       Next i
   Next j
   Worksheets("for PM").Activate
   ПослСтрокаЛист = LastRowInSheet(ActiveSheet)
   ПослСтолбецЛист = LastColumnInSheet(ActiveSheet)
   With Range(Cells(1, 1), Cells(ПослСтрокаЛист, ПослСтолбецЛист)).Borders
       .LineStyle = xlContinuous
       .Weight = xlThin
       .ColorIndex = xlAutomatic
   End With
   Columns("A:S").AutoFit
   Application.CutCopyMode = False
   Worksheets("for PM").Range("A2").Select
   Application.EnableEvents = True
   Application.DisplayAlerts = True
   Application.ScreenUpdating = True
   MsgBox ("Завершено обновление данных!")
End Sub

==================================================
Оформляйте листинги кодов тегами VBA Code[Администратор]

[ambasad]

лучше файл с куском своей рабочей таблицы выложите.
Скорее всего обращаетесь к несуществующему листу......

[Mariam]

Лови

[Михаил С.]

Mariam, а что ж Вы бросили тему http://www.programmersforum.ru/showthread.php?t=209659 и перешли сюда? Там же вроде было решение, и выдает такую же ошибку....

[Mariam]

Кто сказал что я бросила тему, я там вопрос задала, а ответа нет:)

[Михаил С.]

Посмотрите внимательно. Там последний пост мой, в 11:43


Ладно, в любом случае давайте Ваш файл с ошибкой. Неважно, чей макрос будете использовать - посмотрим.

[Mariam]

Правда, прошу прощения не увидела 2ю страницу. Тем не мение если ищешь помощи в нескольких местах, решение приходит быстрее)

[psiho]

Код (vb) Выделить Развернуть

For j = 19 To ПослСтолбецЛист
       Адрес = ActiveSheet.Cells(1, j).Value
       For i = 2 To ПослСтрокаЛист
           If Cells(i, j).Value = 1 Then
               Range(Cells(i, 1), Cells(i, 21)).Copy
               Worksheets("for PM").Activate
               НоваяСтрока = LastRowInSheet(ActiveSheet) + 1
               Range(Cells(НоваяСтрока, 1), Cells(НоваяСтрока, 21)).PasteSpecial (xlPasteValues)
               Cells(НоваяСтрока, 22).Value = Адрес
               Worksheets("Status").Activate
           End If
       Next i
   Next j
Я же говорил, что нужно менять номера столбцов.
Для твоего случая должно быть так:

Код (vb) Выделить Развернуть

For j = 23 To ПослСтолбецЛист
       Адрес = ActiveSheet.Cells(1, j).Value
       For i = 2 To ПослСтрокаЛист
           If Cells(i, j).Value = 1 Then
               Range(Cells(i, 1), Cells(i, 22)).Copy
               Worksheets("for PM").Activate
               НоваяСтрока = LastRowInSheet(ActiveSheet) + 1
               Range(Cells(НоваяСтрока, 1), Cells(НоваяСтрока, 22)).PasteSpecial (xlPasteValues)
               Cells(НоваяСтрока, 23).Value = Адрес
               Worksheets("Status").Activate
           End If
       Next i
   Next j

[psiho]

Чтобы вместо названий столбцов отображались их номера выбери в параметрах Excel закладку "общие" и установи галочку напротив "стиль ссылок R1C1"

[Mariam]

Посмотрите внимательно. Там последний пост мой, в 11:43


Ладно, в любом случае давайте Ваш файл с ошибкой. Неважно, чей макрос будете использовать - посмотрим.

Чуть выше файл "123".

[psiho]

Нужно было сразу этот файлик выкладывать. На, держи:

Код (vb) Выделить Развернуть

For j = 23 To ПослСтолбецЛист  
       Адрес = ActiveSheet.Cells(1, j).Value  
       For i = 3 To ПослСтрокаЛист  
           If Cells(i, j).Value = 1 Then  
               Range(Cells(i, 2), Cells(i, 22)).Copy  
               Worksheets("for PM").Activate  
               НоваяСтрока = LastRowInSheet(ActiveSheet) + 1  
               Range(Cells(НоваяСтрока, 1), Cells(НоваяСтрока, 21)).PasteSpecial (xlPasteValues)  
               Cells(НоваяСтрока, 22).Value = Адрес  
               Worksheets("Status").Activate  
           End If  
       Next i  
   Next j  
Всё остальное в коде не меняется