durumu onaylananları arşivleme

[polis-53]

Merhaba Arkadaşlar ekte gönderdiğim dosyada H sutununda durumu yapıldı olanları butona tıklayarak 2 sayfaya arşivlemek istiyorum yardımcı olabilirseniz sevinirim

 

[Ömer]

.
Merhaba,

Bu şekilde deneyiniz..

Option Compare Text
 
Sub Arşivle()
 
Dim c As Range
Dim sat As Long, son As Long
Dim S2 As Worksheet
Dim ilkadres As Variant
 
Set S2 = Sheets("Sayfa2")
son = Cells(Rows.Count, "A").End(xlUp).Row
S2.Range("A2:G65536").Clear
 
sat = 1
With Range("H2:H" & son)
    Set c = .Find("YAPILDI", LookIn:=xlValues)
    If Not c Is Nothing Then
        ilkadres = c.Address
        Do
            sat = sat + 1
            Range("A" & c.Row & ":G" & c.Row).Copy S2.Range("A" & sat)
 
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> ilkadres
    End If
End With
 
End Sub

.

 

[ynmcan]

Syn. polis-53 :
"C" sütununda bulunan birleştirilmiş hücerleri ayırmanızda bir sorun olmazsa aşağıdaki kodu kulanabilirsiniz. Örnek dosyayı inceyin.

Sub aktar()

'Sayfa2' ye aktarma makrosu --------------------------------------
x = Sheets("YAPILMAYAN HATALAR").Cells(65536, "A").End(xlUp).Row
For sat = 3 To x
For i = 1 To 8
Sheets("Sayfa2").Cells(sat, i) = ""
If Sheets("YAPILMAYAN HATALAR").Cells(sat, 8).Value = "YAPILDI" Then
Sheets("Sayfa2").Cells(sat, i) = Sheets("YAPILMAYAN HATALAR").Cells(sat, i)
Sheets("Sayfa2").Activate
End If
Next i
Next sat

'Sayfa2' de boş satırları silme makrosu ---------------------------
LastRow = Sheets("Sayfa2").UsedRange.Rows.Count
Application.ScreenUpdating = False
For R = LastRow To 1 Step -1
If Application.CountA(Rows(R)) = 0 Then Rows(R).Delete
Next R

'Sayfa2'de kenarlıkları silme makrosu ------------------------------
sat = Sheets("Sayfa2").Cells(65536, "A").End(xlUp).Row
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlInsideHorizontal).LineStyle = False
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlInsideVertical).LineStyle = False
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeTop).LineStyle = False
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeLeft).LineStyle = False
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeRight).LineStyle = False
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeBottom).LineStyle = False

'Sayfa2'de veri olan hücrelere kenarlık çizme makrosu ------------------------------
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlInsideHorizontal).LineStyle = True
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlInsideVertical).LineStyle = True
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeTop).LineStyle = True
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeLeft).LineStyle = True
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeRight).LineStyle = True
Sheets("Sayfa2").Range("A3:H" & sat).Borders(xlEdgeBottom).LineStyle = True

End Sub

 

[polis-53]

Merhaba günaydin arkadaşlar yapılanlar arşivlendiği zaman yapılmayanlar sayfasından da silinmesini istiyorum.

 

[ynmcan]

Syn. Polis-53 ;
Ekteki dosyayı inceleyin.

 

[polis-53]

sayın ynmcany ve diğer arkadaşlar çook teşekkur ederim.