Доброго времени суток! Окажите помощь! Нужно в файле создать листы, присвоить им имена подразделений и из исходного листа скопировать данные относящиеся к этому подразделению (с учетом формата и шапкой таблицы) как в приложенном файле
Заранее спасибо!
Доброго времени суток! Окажите помощь! Нужно в файле создать листы, присвоить им имена подразделений и из исходного листа скопировать данные относящиеся к этому подразделению (с учетом формата и шапкой таблицы) как в приложенном файле
Viper, пока так... грубо но времени не было. Нужно только все листы кроме вашего общего листа удалить. [vba]
Код
Sub NewSheetonList() Dim i As Long, i_n As Long, n As Long, i1 As Long Dim Podrazd() As String, sovpal As Long i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Podrazd(i_n - 1) Dim k As Long k = 1 For i = 2 To i_n k = k + 1 sovpal = 0 Podrazd(i - 1) = Worksheets(1).Cells(i, 1) For n = 1 To k - 2 If Podrazd(n) <> "" Then If Podrazd(n) = Podrazd(i - 1) Then sovpal = sovpal + 1 End If End If Next n If sovpal = 0 Then Worksheets.Add after:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).name = Podrazd(i - 1) Worksheets(1).Cells(1, 1).Resize(, 7).Copy Worksheets(Worksheets.Count).Cells(1, 1) i1 = i s = 0 Do i1 = i1 + 1 s = s + 1 Loop While Worksheets(1).Cells(i1, 1) = Podrazd(i - 1) Worksheets(1).Cells(i1 - s, 1).Resize(s, 7).Copy Worksheets(Worksheets.Count).Cells(2, 1) End If Next i End Sub
[/vba]
Viper, пока так... грубо но времени не было. Нужно только все листы кроме вашего общего листа удалить. [vba]
Код
Sub NewSheetonList() Dim i As Long, i_n As Long, n As Long, i1 As Long Dim Podrazd() As String, sovpal As Long i_n = Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row
ReDim Podrazd(i_n - 1) Dim k As Long k = 1 For i = 2 To i_n k = k + 1 sovpal = 0 Podrazd(i - 1) = Worksheets(1).Cells(i, 1) For n = 1 To k - 2 If Podrazd(n) <> "" Then If Podrazd(n) = Podrazd(i - 1) Then sovpal = sovpal + 1 End If End If Next n If sovpal = 0 Then Worksheets.Add after:=Worksheets(Worksheets.Count) Worksheets(Worksheets.Count).name = Podrazd(i - 1) Worksheets(1).Cells(1, 1).Resize(, 7).Copy Worksheets(Worksheets.Count).Cells(1, 1) i1 = i s = 0 Do i1 = i1 + 1 s = s + 1 Loop While Worksheets(1).Cells(i1, 1) = Podrazd(i - 1) Worksheets(1).Cells(i1 - s, 1).Resize(s, 7).Copy Worksheets(Worksheets.Count).Cells(2, 1) End If Next i End Sub