• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Karışık kopyalama...

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
 
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.
 
Bende ayarladığnız bu yeni düzene uyarlamak istemiştim. Sonuç başarısız mı ?
 
Maalesef, acaba şu A65536'lardan birinde mi hata var. Malum 2 sütun kaydı.
 
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.
 
Selamlar,

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

Kod: 
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
 
Teşekkür ederim. Şimdi oldu. Bazı yerlerini yorumlayamadım, ama olsun bu da kâfi...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst