Karışık kopyalama...

[Skorpiyon]

Sayın leumruk,

İlk defa (yukarıdaki mesajları okumadım) ne yaptığımı bilmeden kod değiştirdim. Aşağıdaki şekilde bir dener misiniz ?

Sub GRUP_OLUŞTUR()
Set S1 = Sheets("KRİTER")
Set S2 = Sheets("TABLO")
S2.Select
For X = 7 To [A65536].End(3).Row Step 8
For Y = 5 To 11 Step 3
Range(Cells(X, 2), Cells(X + 1, 2)).Copy Cells(X, Y)
Next
Next

SÜTUN = 4
SATIR = 7
For X = 7 To 13 Step 3
For Y = 10 To [A65536].End(3).Row Step 8
For Z = 3 To 7
If Cells(Y, X) = "A" Or Cells(Y, X) = "B" Or Cells(Y, X) = "C" Or Cells(Y, X) = "D" Or Cells(Y, X) = "E" Then
Set BUL = Range("A" & Y - 1 & ":A65536").Find(S1.Cells(Z, SÜTUN), LookAt:=xlWhole)
If Not BUL Is Nothing Then
Cells(BUL.Row, 2).Copy Cells(SATIR, X + 1)
SATIR = SATIR + 1
End If
End If
Next
SATIR = SATIR + 3
Next
SATIR = 4
SÜTUN = SÜTUN + 1
Next

SÜTUN = 9
SATIR = 6
For X = 7 To 13 Step 3
Range(Cells(1, X), Cells(65536, X + 1)).Copy Cells(1, 255)
For Y = 3 To S1.[F65536].End(3).Row
Set BUL = Range("IU:IU").Find(S1.Cells(Y, SÜTUN), LookAt:=xlWhole)
If Not BUL Is Nothing Then
Range(Cells(BUL.Row, 256), Cells(BUL.Row + 6, 256)).Copy Cells(SATIR, X + 1)
SATIR = SATIR + 8
End If
Next
SATIR = 2
SÜTUN = SÜTUN + 1
Next
Columns("IU:IV").Delete
Set S1 = Nothing
Set S2 = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[leumruk]

Syn. Şaban hocam, kodlarda hiç bir sorun yok. Ben tablonun yerinde ufak bir oynama yaptım. Doğal olarak makro uyumu da bozuldu. Benim istediğim, makroyu yeni tabloya uyarlamak. Tablonun önüne 2 sütun, 3 de satır ekledim, o kadar.

 

[Skorpiyon]

Bende ayarladığnız bu yeni düzene uyarlamak istemiştim. Sonuç başarısız mı ?

 

[leumruk]

Maalesef, acaba şu A65536'lardan birinde mi hata var. Malum 2 sütun kaydı.

 

[Skorpiyon]

Birde A65536'yı C65536 olarak değiştirip deneyiniz.

 

[leumruk]

Gene olmadı. Sanırım satır ve sütunlar numaralarla ifade ediliyor. Onu da ben anlayamıyorum. Hangi numara hangi satır, hangi numara hangi sütun bir türlü ayıramadım.

 

[Korhan Ayhan]

Selamlar,

Kodu aşağıdaki şekilde değiştirip denermisiniz. Nerelerin değiştiğini bir önceki yanıtımdaki dosyayı inceleyerek görebilirsiniz.

Sub GRUP_OLUŞTUR()
    Set S1 = Sheets("KRİTER")
    Set S2 = Sheets("TABLO")
    S2.Select
    For X = 5 To [C65536].End(3).Row Step 8
    For Y = 7 To 13 Step 3
    Range(Cells(X, 4), Cells(X + 1, 4)).Copy Cells(X, Y)
    Next
    Next
 
    SÜTUN = 2
    SATIR = 7
    For X = 6 To 12 Step 3
    For Y = 7 To [C65536].End(3).Row Step 8
    For Z = 3 To 7
    If Cells(Y, X) = "A" Or Cells(Y, X) = "B" Or Cells(Y, X) = "C" Or Cells(Y, X) = "D" Or Cells(Y, X) = "E" Then
    Set BUL = Range("C" & Y - 1 & ":C65536").Find(S1.Cells(Z, SÜTUN), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    Cells(BUL.Row, 4).Copy Cells(SATIR, X + 1)
    SATIR = SATIR + 1
    End If
    End If
    Next
    SATIR = SATIR + 3
    Next
    SATIR = 7
    SÜTUN = SÜTUN + 1
    Next
 
    SÜTUN = 7
    SATIR = 5
    For X = 6 To 12 Step 3
    Range(Cells(1, X), Cells(65536, X + 1)).Copy Cells(1, 255)
    For Y = 3 To S1.[F65536].End(3).Row
    Set BUL = Range("IU:IU").Find(S1.Cells(Y, SÜTUN), LookAt:=xlWhole)
    If Not BUL Is Nothing Then
    Range(Cells(BUL.Row, 256), Cells(BUL.Row + 6, 256)).Copy Cells(SATIR, X + 1)
    SATIR = SATIR + 8
    End If
    Next
    SATIR = 5
    SÜTUN = SÜTUN + 1
    Next
    Columns("IU:IV").Delete
    Set S1 = Nothing
    Set S2 = Nothing
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[leumruk]

Teşekkür ederim. Şimdi oldu. Bazı yerlerini yorumlayamadım, ama olsun bu da kâfi...