Страницы: 1
RSS
Перенос таблицы по фильтру на новый лист с ведённым именем
 
повторите ваше сообщение еще раз и приложите небольшой файл-пример
 
Например, в таблице выбрать фильтр 12(а в дальнейшем который потребуется) по столбцу KOD_S и вывести всю эту информацию на новый лист. Нужно, чтобы макрос создал лист с именем, который затребует пользователь и на этот лист скопируется инфа по выбранному фильтру. Ниже приведенный код работает, только с ранее созданным листом. Пытался через Sheets.Add.Name = "Мое_имя" сделать, но он добавляет очень много листов без назначенного имени.
Код
Sub iCopy()  
Dim Sht As Worksheet  
Dim iLastRow As Long  
  iLastRow = Cells(Rows.Count, 1).End(xlUp).Row  
    For Each Sht In Worksheets  
      If Sht.Name <> "Лист1" Then  
       If Sht.Name = "Лист2"  Then  
         With Sht  
            Range("A1:D" & iLastRow).Copy  
            .Cells(1, 1).PasteSpecial xlPasteColumnWidths  
            .Cells(1, 1).PasteSpecial xlPasteValues  
         End With  
       End If  
      End If  
    Next  
End Sub

Если знаете, как решить данную проблему, буду благодарен.
Изменено: vikttur - 10.06.2021 23:43:58
 
Виктор Резнов, запускать макрос с активного листа с исходной таблицей
Код
Sub iCopy()
Dim Sht As Worksheet, tt As String, sh As Worksheet
Set sh = ActiveSheet
tt = Application.InputBox("задайте имя для нового листа", Type:=2)
For Each Sht In Worksheets
    If Sht.Name = tt Then k = k + 1: Exit For
Next Sht
If k = 0 Then
    Sheets.Add.Name = tt
    sh.Range("A1:D" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
    Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteColumnWidths
    Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteValues
Else
    x = MsgBox("Лист с заданными именем существует." & Chr(10) & "ОК - данные на существующем листе будут стерты и вставлены новые" & Chr(10) & "Отмена - макрос прервется", vbOKCancel)
    If x = vbOK Then
        Worksheets(tt).Cells.Clear
        sh.Range("A1:D" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
        Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteColumnWidths
        Worksheets(tt).Cells(1, 1).PasteSpecial xlPasteValues
    Else
        Exit Sub
    End If
End If
End Sub

Изменено: Mershik - 10.06.2021 20:38:23
Не бойтесь совершенства. Вам его не достичь.
 
Спасибо большое!
Страницы: 1
Наверх