Всем привет! Требуется автоматически добавлять строку с ФИО в листе блок1 или блок2 в зависимости от того, какой статус имеет ФИО во вкладке База данных. Т.е. в зависимости от того, какой статус мы пишем в Базе данных, в одной из вкладок: блок1 или блок2 должны автоматически появиться ФИО
Всем привет! Требуется автоматически добавлять строку с ФИО в листе блок1 или блок2 в зависимости от того, какой статус имеет ФИО во вкладке База данных. Т.е. в зависимости от того, какой статус мы пишем в Базе данных, в одной из вкладок: блок1 или блок2 должны автоматически появиться ФИОSedoy
Sub перенос() Dim r1&, r2&, i& r1 = Sheets("блок1").Range("B" & Rows.Count).End(xlUp).Row + 1 r2 = Sheets("блок2").Range("B" & Rows.Count).End(xlUp).Row + 1 For i = 2 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i, 3) = "блок1" Then Sheets("блок1").Cells(r1, 2) = Cells(i, 2) r1 = r1 + 1 End If If Cells(i, 3) = "блок2" Then Sheets("блок2").Cells(r2, 2) = Cells(i, 2) r2 = r2 + 1 End If Next End Sub
[/vba]
Ну если макросом то наверное так [vba]
Код
Sub перенос() Dim r1&, r2&, i& r1 = Sheets("блок1").Range("B" & Rows.Count).End(xlUp).Row + 1 r2 = Sheets("блок2").Range("B" & Rows.Count).End(xlUp).Row + 1 For i = 2 To Range("B" & Rows.Count).End(xlUp).Row If Cells(i, 3) = "блок1" Then Sheets("блок1").Cells(r1, 2) = Cells(i, 2) r1 = r1 + 1 End If If Cells(i, 3) = "блок2" Then Sheets("блок2").Cells(r2, 2) = Cells(i, 2) r2 = r2 + 1 End If Next End Sub
У меня получилось вот что, через событие листа База данных: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 4 And Cells(Target.Row, 1).Value <> "" And Cells(Target.Row, 2).Value <> "" And Cells(Target.Row, 3).Value <> "" Then If Cells(Target.Row + 1, Target.Column).Value = "" Then With Worksheets(Cells(Target.Row, 3).Value) .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 1).Value = Val(.Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 1).Value) + 1 .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Value = Cells(Target.Row, 2).Value End With End If End If
End Sub
[/vba] но это явно сыро...
У меня получилось вот что, через событие листа База данных: [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column < 4 And Cells(Target.Row, 1).Value <> "" And Cells(Target.Row, 2).Value <> "" And Cells(Target.Row, 3).Value <> "" Then If Cells(Target.Row + 1, Target.Column).Value = "" Then With Worksheets(Cells(Target.Row, 3).Value) .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 1).Value = Val(.Cells(.Cells(Rows.Count, 2).End(xlUp).Row, 1).Value) + 1 .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Value = Cells(Target.Row, 2).Value End With End If End If
С учетом того, что данные могут не только добавляться, но и (теоретически) изменяться, что в дальнейшем может приводить к путанице, я бы сделал так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)) Is Nothing Then Exit Sub Dim ws1 As Worksheet, ws2 As Worksheet Dim Col1 As New Collection, Col2 As New Collection Dim arr(), I As Long Set ws1 = Worksheets("блок1"): Set ws2 = Worksheets("блок2") ws1.Range("A2:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row).ClearContents ws2.Range("A2:B" & ws2.Cells(Rows.Count, "B").End(xlUp).Row).ClearContents arr = Range("B2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Value For I = 1 To UBound(arr) If arr(I, 2) = "блок1" Then Col1.Add arr(I, 1) ElseIf arr(I, 2) = "блок2" Then Col2.Add arr(I, 1) End If Next With Col1 ReDim arr(1 To .Count, 1 To 2) For I = 1 To .Count arr(I, 1) = I arr(I, 2) = .Item(I) Next ws1.Range("A2").Resize(UBound(arr), 2).Value = arr End With With Col2 ReDim arr(1 To .Count, 1 To 2) For I = 1 To .Count arr(I, 1) = I arr(I, 2) = .Item(I) Next ws2.Range("A2").Resize(UBound(arr), 2).Value = arr End With End Sub
[/vba]
С учетом того, что данные могут не только добавляться, но и (теоретически) изменяться, что в дальнейшем может приводить к путанице, я бы сделал так [vba]
Код
Private Sub Worksheet_Change(ByVal Target As Range) If Intersect(Target, Range("C2:C" & Cells(Rows.Count, "C").End(xlUp).Row)) Is Nothing Then Exit Sub Dim ws1 As Worksheet, ws2 As Worksheet Dim Col1 As New Collection, Col2 As New Collection Dim arr(), I As Long Set ws1 = Worksheets("блок1"): Set ws2 = Worksheets("блок2") ws1.Range("A2:B" & ws1.Cells(Rows.Count, "B").End(xlUp).Row).ClearContents ws2.Range("A2:B" & ws2.Cells(Rows.Count, "B").End(xlUp).Row).ClearContents arr = Range("B2:C" & Cells(Rows.Count, "C").End(xlUp).Row).Value For I = 1 To UBound(arr) If arr(I, 2) = "блок1" Then Col1.Add arr(I, 1) ElseIf arr(I, 2) = "блок2" Then Col2.Add arr(I, 1) End If Next With Col1 ReDim arr(1 To .Count, 1 To 2) For I = 1 To .Count arr(I, 1) = I arr(I, 2) = .Item(I) Next ws1.Range("A2").Resize(UBound(arr), 2).Value = arr End With With Col2 ReDim arr(1 To .Count, 1 To 2) For I = 1 To .Count arr(I, 1) = I arr(I, 2) = .Item(I) Next ws2.Range("A2").Resize(UBound(arr), 2).Value = arr End With End Sub