sayfadan sayfaya şartlı veri aktarma....

[muratozmenler]

Private Sub CommandButton1_Click()
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim MyRng As Range
Dim Nrow As Long
Set Sh1 = Sheets("ANA")
Set Sh2 = Sheets("SONUÇ")
Sh2.Range("A2:N45").Clear

For Each MyRng In Sh1.Range("A1:N50")
If MyRng.Interior.ColorIndex = 6 Then

Nrow = Sh2.Range("A65536").End(xlUp).Row + 1
Sh1.Rows(MyRng.Row).Copy
Sh2.Range("A" & Nrow).PasteSpecial
End If
Next
Application.CutCopyMode = False
Range("A1").Select

Me.Hide
Sheets("SONUÇ").Select
Rows("2:45").Select
With Selection.Font
.Name = "Arial"
.Size = 7
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
[IV:IV].ClearContents
[IV1] = "=A1"
[IV1].AutoFill Destination:=Range("IV1:IV" & [A65536].End(3).Row), Type:=xlFillDefault
[IV:IV].Value = [IV:IV].Value
For X = [IV65536].End(3).Row To 1 Step -1
If WorksheetFunction.CountIf(Range("IV1:IV" & X), Cells(X, "IV")) > 1 Then Rows(X).Delete
Next
[IV:IV].ClearContents
ActiveWindow.SelectedSheets.PrintPreview
Sheets("ANA").Select
Me.Show

End Sub


bu kod ile önce sonuç sayfasını temizleyip ana sayfada a2:n45 aralığında sarı renkli hücre var ise onları bulup kopyalayıp sonuç sayfasına aktardıktan sonra a2:a sütununda birbirine benzer kayıtları silerek bir tanesini bırakıp 2 nci satırdan itibaren yazı puntunu 7 olarak yazdırıp sayfayı önizleme yaptırmaktadır.
kod çalışıyor fakat yaptığı işlem biraz zaman aldığı için uzun sürmekte.

bu kodları kısaltmanın yani bu işlemi yapmanın kısa yolu varmı..?

gerçekleşmesi istenen kod: (ilk olarak sonuç sayfasını 2 nci satırdan itibaren (1nci satır kalacak) temizledikten sonra ana sayfada a2:n45 aralığında sarı renkli hücre varsa sarı renkli olan satırı kopyalayıp sonuç sayfasına aktarıp aktarma yaparkende aynı satırda birden fazla sarı renkli hücre var ise sadece bir satır olarak alıp kopyaladıktan sonra aktarılan değerlerinde yazı karakterini 7 punt yapıp sayfayı önizleme yapmaktır.)

 

[Korhan Ayhan]

Selamlar,

Kullanıdığınız kodu aşağdaki şekilde değiştirip denermisiniz.

Private Sub CommandButton1_Click()
    Dim Sh1 As Worksheet, Sh2 As Worksheet
    Dim MyRng As Range
    Dim Nrow As Long
    Set Sh1 = Sheets("ANA")
    Set Sh2 = Sheets("SONUÇ")
    Sh2.Range("A2:N65536").ClearContents
    Sh2.Range("A2:N65536").Interior.ColorIndex = xlNone
    
        For Each MyRng In Sh1.Range("A1:N" & Sh1.Range("A65536").End(3).Row)
            If MyRng.Interior.ColorIndex = 6 Then
            If WorksheetFunction.CountIf(Sh2.Range("A2:A65536"), Sh1.Cells(MyRng.Row, "A")) = 0 Then
            Nrow = Sh2.Range("A65536").End(xlUp).Row + 1
            Sh1.Rows(MyRng.Row).Copy Sh2.Range("A" & Nrow)
            End If
            End If
        Next
    
    Range("A1").Select
    Sh2.Select
    
    With Rows("2:65536").Font
        .Size = 7
        .Name = "Arial"
    End With
    
    Range("A1").Select
    
    Me.Hide
    ActiveWindow.SelectedSheets.PrintPreview
    Sheets("ANA").Select
    Me.Show
End Sub

 

[muratozmenler]

Teşekkürler sayın korhan ayhan bey..... Bu kodle daha hızlı bilgi aldım tekrardan teşekkürler...