Kapalıdan veri almak satır ve sütun verilerini düzenlemek

[Believing]

Sayın Uzman Arkadaşlar,

Eğitim kayıtlarını tutuğumuz bir programdan Excel olarak kayıt ettiğimiz "Database_EGITIM" isimli bir çalışma kitabı oluşturuyorum.
"Database_EGITIM" isimli çalışma kitabındaki verileri, açık olan çalışma kitabına atanan butonlar yardımı ile transfer etmek istiyorum.
Kapalı kitaptaki verilerde başlık satırında kaymalar olduğundan, satır ve sütun verilerini düzenlemek ve sonrasında birçok rapor elde etmek istiyorum.
Detaylı anlatım ve olması gereken düzenlemenin örneği "EGITIM_ANALIZI_ACIK" isimli kitapta bulunmaktadır.
İşlenecek verilerin yılsonuna kadar 50.000 alaşacağından siz uzman arkadaşların yardımlarını rica ederim.

Saygılarımla,

 

[Ziynettin]

Kapalı dosyadan sadece veri alma işlemi yapıldı.

Dosyalar aynı klasörde olacak

 

[Believing]

Sayın Ziynettin Bey,

Ellerinize emeğinize sağlık, çok güzel bir çalışma olmuş.
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınızı helal ediniz lütfen.

Saygılarımla,

 

[Believing]

Sayın Ziynettin,

Affınıza sığınarak son isteğim daha olacaktır.
Adı ve Soyadı sütun bilgilerini Adı sütununda birleştirerek fazla sütunu silmek mümkün müdür?

Saygılarımla,

 

[Ziynettin]

Adı ve Soyadı sütun bilgilerini Adı sütununda birleştirerek fazla sütunu silmek mümkün müdür?

 

[Believing]

Sayın Ziynettin,

Dosyayı kendi dosyalarıma uyguladıktan sonra satırlarda kaymalar oldu.
Bu dosyalar ekteki gibi olup, formatları orjinal dosyalar ile aynıdır.
Kodlar ile biraz uğraştım ama bir sonuç alamadım.

Saygılarımla,

 

[Ziynettin]

Önceki dosyada J sütununda katılımcı sayısı referans alınarak yazmıştım kodu.

Aşağıdaki kod ise tablo başlıkları referans alınmıştır.

Sub kod_1()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\"
dosya = "Database_EGITIM.xlsx"
GetObject (yol & dosya)
Set s1 = Workbooks(dosya).Sheets("Sheet")

son = s1.Cells(Rows.Count, 1).End(3).Row - 1
a = s1.Range("A2:K" & son).Value
Windows(dosya).Visible = True
Workbooks(dosya).Close 0
Set dz = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
For i = 1 To UBound(a)
    If a(i, 1) = "Kayıt Kodu" Then n = n + 1: y1 = a(i, 11) & "#" & n:
    a(i, 11) = y1
    If a(i, 11) = y1 Then y2 = a(i, 11)
    a(i, 11) = y2
    If Not dz.exists(a(i, 11)) Then
        dz(a(i, 11)) = i
    Else
        ds(a(i, 11)) = i
    End If
Next i

w1 = dz.items
w2 = ds.items

ReDim b(1 To UBound(a), 1 To 19)
For j = 0 To dz.Count - 1
    
    For i = w1(j) + 3 To w2(j)
        say = say + 1
        For x = 1 To 10
            b(say, x) = a(w1(j) + 1, x)
        Next x
        
        If b(say, 8) = "Saat" Then
            b(say, 7) = b(say, 7) * 60: b(say, 8) = "Dakika"
        End If
        b(say, 11) = a(i, 1)
        b(say, 12) = a(i, 2) & " " & a(i, 3)
        b(say, 13) = a(i, 4)
        b(say, 14) = a(i, 5)
        b(say, 15) = a(i, 6)
        b(say, 16) = a(i, 8)
        b(say, 18) = a(i, 9)
        b(say, 19) = a(i, 10)
    
    Next i

Next j

If say > 0 Then
    Set s2 = Sheets("DATABASE")
    s2.Range("A3:U" & Rows.Count).ClearContents
    s2.[A3].Resize(say, 2).NumberFormat = "@"
    s2.[A3].Resize(say, 19) = b
    Application.ScreenUpdating = True
    MsgBox "İşlem tamam...", vbInformation
Else
    Application.ScreenUpdating = True
    MsgBox "İşlem YOK...", vbCritical
End If
End Sub

 

[Believing]

Sayın Ziynettin,

Ellerinize ve emeğinize sağlık, fazlasıyla güzel bir çalışma oldu.
ALLAH sizden ve sevdiklerinizden razı olsun.
Hakkınızı helal ediniz lütfen. Cuma gününüzün hayırlara vesile olmasını dilerim.

Saygılarımla,