Добрый вечер. Нужно макросом вывести всю информацию по районам на новые листы одновременно и название листа совпадает с номером района. Например, в данной таблице в столбце S_KOD есть районы с номерами 100,101,102,103,104 и макросом выводим сотый район со всей информацией по нему на новый лист с названием этого же района 100.Далее 101 на другой лист с таким же алгоритмом и т.д. Пытался сделать через код, который приведен ниже, но он слишком объемный получается для большой таблицы и диапазон ячеек слишком условный.
Sub iCopy()
Application.ScreenUpdating = False
Dim wsh As Worksheet, tt As String, sh As Worksheet, col As New Collection, lr As Long, ShN As String
Set sh = ActiveSheet
lr = sh.Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To lr
On Error Resume Next
col.Add sh.Cells(i, 1), CStr(sh.Cells(i, 1))
Next i
For i = 1 To col.Count
ShN = col(i)
sh.ShowAllData
sh.Range("A1:J" & lr).AutoFilter Field:=1, Criteria1:=col(i)
For Each wsh In Worksheets
If wsh.Name = ShN Then k = k + 1: Exit For
Next wsh
If k = 0 Then
Sheets.Add.Name = ShN
sh.Range("A1:J" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
ActiveSheet.Cells(1, 1).PasteSpecial xlPasteColumnWidths
ActiveSheet.Cells(1, 1).PasteSpecial xlPasteValues
Else
With Worksheets(ShN)
.Cells.Clear
sh.Range("A1:J" & sh.Cells(Rows.Count, 1).End(xlUp).Row + 1).Copy
.Cells(1, 1).PasteSpecial xlPasteColumnWidths
.Cells(1, 1).PasteSpecial xlPasteValues
End With
End If
Next i
sh.ShowAllData
Application.ScreenUpdating = True
End Sub
Здравствуйте снова, обсудить в этой же теме тот же вопрос только с некоторыми изменениями возможно? Алгоритм все тот же, каждый район с нового листа, только некоторые номера(районы) нужно объединить. Например, 108 и 123; 110 и124; 164 и 168; 165 166 167; 181 138 186 187.Все по столбцу S_KOD.
Логика в том, что районы, которые сгруппированы, находятся в одной области, потому их делить на каждую страницу нельзя. А так в данной таблице конкретное с конкретным сводится.
Sub qq()
Application.ScreenUpdating = False
Dim sh As Worksheet
Dim ar, i&
Set sh = ActiveSheet
ar = Array("101", "103", "104", Array("108", "123"), Array("110", "124"), Array("164", "168"), Array("165", "166", "167"), Array("138", "181", "186", "187"))
For i = LBound(ar) To UBound(ar)
On Error Resume Next
sh.ShowAllData
On Error GoTo 0
sh.AutoFilter.Range.AutoFilter Field:=1, Criteria1:=ar(i), Operator:=xlFilterValues
Worksheets.Add after:=Sheets(Sheets.Count)
On Error Resume Next
ActiveSheet.Name = ar(i)
ActiveSheet.Name = Join(ar(i), "_")
On Error GoTo 0
sh.AutoFilter.Range.Copy ActiveSheet.Range("A1")
Next
sh.ShowAllData
Application.ScreenUpdating = True
End Sub