Tablo aktarma

[Barons]

Merhaba
Ekteki dosyadaki "v" sayfasındaki tablodaki verileri "database" sayfasına veri tabanı mantığı ile atmak istiyorum.Döngü kullanarak makro ile yapmak mümkünmüdür?
Yaptığım düğmede ilk satırı gönderiyorum ama tüm tablo için kodlar çok uzuyor.
Yardımcı olacak herkese şimdiden teşekkürler,,,

 

[janveljan]

Dosyayı ekledim inceleyin lütfen.

Sub matris()
Application.ScreenUpdating = False
Set sd = Sheets("database")
Set sv = Sheets("v")
sd.Range("A2:L73").ClearContents
For j = 1 To 3 'sütun
For t = 1 To 3 'grup
For i = 1 To 8 'satır
    sat = sd.[A65536].End(xlUp).Row + 1
    sd.Cells(sat, 1) = sat - 1
    sd.Cells(sat, 2) = sv.Cells(2, 1)
    sd.Cells(sat, 3) = sv.Cells(1, j * 9 - 6) '3,12,21
    sd.Cells(sat, 4) = sv.Cells(t * 10 - 8, 2) '2,12,22
    sd.Cells(sat, 5) = sv.Cells(t * 10 - 8, j * 9 - 5) '2,12,22;4,13,22
For k = 1 To 7 'grup içinde sütun
    sut = k + 5
    sd.Cells(sat, sut) = sv.Cells(t * 10 - 7 + i, j * 9 - 6 + k)
Next k
Next i
Next t
Next j
Application.ScreenUpdating = False
End Sub

 

[Barons]

Sn.janveljan

1.Vakit ayırıp ilgilenme nezaketi gösterdiğiniz için,
2.Mükemmel çözüm için
3.ve yazılan kodun çok hızlı çalışması sebebiyle,

Size 3 teşekkür borçluyum.
Saygılarımla

Not:Çok şey istemiş olmak istemiyorum ancak bu vardiya raporunun sürekli hergün database sayfasına kaydedilmesi sebebi ile sizin kodlardaki clear.content bölümünü silip sayaç ile altalta aktardım.Bu kısmı tamam ancak 2 sorun kaldı; mükerrer kayda izin vermemesi ve boş olan verileri almaması yani TİP ile başlayan ve MK.MT ile biten satırlarda veri yoksa almamasını nasıl sağlarım.?
Tekrar gönülden çok çok teşekkürler

 

[janveljan]

Kodları aşağıdaki şekilde düzenlerseniz sorun çözülür.

Sub matris()
Application.ScreenUpdating = False
Set sd = Sheets("database")
Set sv = Sheets("v")
'sd.Range("A2:L73").ClearContents
For j = 1 To 3 'sütun
For t = 1 To 3 'grup
For i = 1 To 8 'satır
    sat = sd.[A65536].End(xlUp).Row + 1
For k = 1 To 7 'grup içinde sütun
    sut = k + 5
    sd.Cells(sat, sut) = sv.Cells(t * 10 - 7 + i, j * 9 - 6 + k)
Next k
    If sd.Cells(sat, 12) <> "" Then
    sd.Cells(sat, 1) = sat - 1
    sd.Cells(sat, 2) = sv.Cells(2, 1)
    sd.Cells(sat, 3) = sv.Cells(1, j * 9 - 6) '3,12,21
    sd.Cells(sat, 4) = sv.Cells(t * 10 - 8, 2) '2,12,22
    sd.Cells(sat, 5) = sv.Cells(t * 10 - 8, j * 9 - 5) '2,12,22;4,13,22
    End If
Next i
Next t
Next j
Application.ScreenUpdating = true
End Sub

 

[Barons]

Hocam bu ne hız...maşallah
Harika bir çözüm ve yine tam 12 den...tekrar çok çok teşekkürler,
Allah sizinde her işinizi kolaylaştırsın

 

[Barons]

--------------------------------------------------------------------------------

Sn.janveljan

Unutmuşum,Ekteki dosyada diğer 2 sayfadaki daha basit olan tablolarıda aynı mantıkla veritabanına atmam gerekiyor.
Matris isimli kodu uyarlamaya çalıştım ancak oradaki matris rakamlarında sanırım problem çıkıyor.
Son kez Yardımcı olursanız çok memnun olurum.

 

[janveljan]

Ekteki dosyayı inceleyin lütfen.

 

[Barons]

Harika olmuş..elinize sağlık...mükemmel sonuç...tanımadığınız bir insan için yorulmanız, karşılık beklemeden ayırdığınız vakit için;usulen teşekkür değil size gönülden dualarımı yolluyorum.

 

[janveljan]

Teşekkür ederim elimizden geldiği kadar yardımcı olmaya çalışıyoruz.

 

[Barons]

Rahat olduğunuz bir zaman ve zeminde koddaki for next ve rakamların açılımlarını anlatırsanız çok memnun olurum.Çünkü 65000 satırı doldurdum ve kaydet dememe rağmen ,hızda en ufak azalma olmadı ve çok hızlı bir şekilde veriler aktarıldı.Dosyada en ufak bir ağırlaşma olmaması tamamen kodla ilgili,çünkü veri aktarmada klasik yöntemlerde yani activecell.offset(0,1).....bir süre sonra kaydet dendiğinde 25-30 binden sonra ciddi yavaşlamalar oluyor ama bu şekil kaydetmede en ufak bir azalma sözkonusu olmuyor.
Tekrar teşekkürler