Merhaba,
İşin içinden çıkamadım. Ücretli veya ücretsiz yardım tekliflerine açığım.
Ekteki dosyada çalışanlarımız 5 grupta yer alıyor. A,B,C,D ve X. Tabloda genel bir değişiklik yaptığım için şu an B'den bir satırı D'ye yada C'den A'ya gibi hareket ettirdiğim zaman üst yada alttan bir satırı da beraber getiriyor. Yani tek başına hareket etmiyor. Bunun nasıl üstesinden gelebilirim? Aynı zamanda B-C-D satırları için; B1,B2,B3,B4,B5 C1,C2,C3,C4,C5 D1,D2,D3,D4,D5 şeklinde sıralama şartı verebilir miyiz? Yani bir personel B grubu operatörü olacaksa B1 dediğinde B'nin en üst sırasına geçecek. Hamurda olacaksa B2 yazacağım B'nin 2. satırına geçecek. Birde bunlar olurken B1 yaazarsam D hücresi otomatik opeatör olsa aynı şkeilde C1 ve D1 için. Yada B4 yazınca döner tabla olsa yine C4 D4 içinde geçerli olacak şekilde. Private Sub Worksheet_Change(ByVal Target As Range) Dim Grup_A As Long, Grup_B As Long, Grup_C As Long, Grup_D As Long, Grup_X As Long Dim Alan As Range, Bul As Long, Renk As Long, Sutun As Integer, Kod(1 To 5) As Variant Set Alan = Range("B3:B250") If Intersect(Target, Alan) Is Nothing Then Exit Sub If Target.Cells.CountLarge > 1 Then Exit Sub If Target <> "" Then Kod(1) = "A" Kod(2) = "B" Kod(3) = "C" Kod(4) = "D" Kod(5) = "X" Select Case UCase(Target) Case "A", "B", "C", "D", "X" Case Else MsgBox "Lütfen aşağıdaki değerlerden birisini giriniz!" & vbCr & vbCr & _ "Girdiğiniz değer ; " & Target.Value & vbCr & vbCr & Join(Kod, vbCr), vbCritical Target.Resize(2).ClearContents Target.Select Exit Sub End Select Application.ScreenUpdating = False Grup_A = WorksheetFunction.CountIf(Alan, "A") Grup_B = WorksheetFunction.CountIf(Alan, "B") Grup_C = WorksheetFunction.CountIf(Alan, "C") Grup_D = WorksheetFunction.CountIf(Alan, "D") Grup_X = WorksheetFunction.CountIf(Alan, "X") Select Case UCase(Target) Case "A": Renk = 3506772 Case "B": Renk = 13311 Case "C": Renk = 11892015 Case "D": Renk = 65535 Case "X": Renk = 14277081 Case Else: Renk = Target.Interior.Color End Select Range("B" & Target.Row).Resize(1, 53).Interior.Color = Renk Sutun = Cells.Find("*", Cells(1, 1), SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column ' Range("I" & Target.Row).Resize(1, Sutun - 15).Interior.Color = Renk If WorksheetFunction.Max(Grup_A, Grup_B, Grup_C, Grup_D, Grup_X) = 0 Then Exit Sub Select Case UCase(Target) Case "A" If Grup_A = 0 Then Else If Cells(3, "C") = "" Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(3, "A").Insert Shift:=xlDown ElseIf Grup_A > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "A" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Bul = Bul + 1 If Bul > 0 Then If Bul <> Target.Row And Bul <> Target.Row Then If UCase(Target) <> UCase(Target.Offset(-1)) And UCase(Target) <> UCase(Target.Offset(-2)) Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown End If End If Else GoTo 10 End If ElseIf Grup_B > 0 Then 10 Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "B" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(3, "A").Insert Shift:=xlDown ElseIf Grup_C > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "C" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_D > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "D" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_X > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "X" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown End If End If Case "B" If Grup_B = 0 Then Else If Grup_B > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "B" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 Then If Bul + 0 <> Target.Row And Bul - 2 <> Target.Row Then If UCase(Target) <> UCase(Target.Offset(1)) And UCase(Target) <> UCase(Target.Offset(-2)) Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If Else GoTo 20 End If ElseIf Grup_A > 0 Then 20 Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "A" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_C > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "C" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_D > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "D" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_X > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "X" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown End If End If Case "C" If Grup_C = 0 Then Else If Grup_C > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "C" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 Then If Bul + 0 <> Target.Row And Bul - 2 <> Target.Row Then If UCase(Target) <> UCase(Target.Offset(1)) And UCase(Target) <> UCase(Target.Offset(-2)) Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If Else GoTo 30 End If ElseIf Grup_B > 0 Then 30 Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "B" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_D > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "D" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_X > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "X" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown ElseIf Grup_A > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "A" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If End If Case "D" If Grup_D = 0 Then Else If Grup_D > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "D" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 Then If Bul + 0 <> Target.Row And Bul - 2 <> Target.Row Then If UCase(Target) <> UCase(Target.Offset(1)) And UCase(Target) <> UCase(Target.Offset(-2)) Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If Else GoTo 40 End If ElseIf Grup_C > 0 Then 40 Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "C" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_B > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "B" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_A > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "A" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_X > 0 Then Bul = Evaluate("=MIN(IF(" & Alan.Address & "=""" & "X" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul, "A").Insert Shift:=xlDown End If End If End If Case "X" If Grup_X = 0 Then Else If Grup_X > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "X" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 Then If Bul + 0 <> Target.Row And Bul - 2 <> Target.Row Then If UCase(Target) <> UCase(Target.Offset(1)) And UCase(Target) <> UCase(Target.Offset(-2)) Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If Else GoTo 50 End If ElseIf Grup_D > 0 Then 50 Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "D" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_C > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "C" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_B > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "B" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If ElseIf Grup_A > 0 Then Bul = Evaluate("=MAX(IF(" & Alan.Address & "=""" & "A" & """,IF(ROW(" & Alan.Address & ")<>ROW(" & Target.Address & "),ROW(" & Alan.Address & "))))") If Bul > 0 And Bul + 0 <> Target.Row Then Range("A" & Target.Row).Resize(2).EntireRow.Cut Cells(Bul + 0, "A").Insert Shift:=xlDown End If End If End If End Select Application.ScreenUpdating = True End If Set Alan = Nothing End Sub
https://s7.dosya.tc/server19/swe8ef/Foruma.xlsm.html