Özet tablo benzeri bir tablo düzenleme

[HAKANP]

Selamlar, herkese kolay gelsin.

Ekte koymuş olduğum bir dosya var. Dosyanın, ilk tablosunda daha önceden bize iş başvurusu yapmış kişilerin, bizden önce çalışmış oldukları işyerlerine ait bilgiler bulunmakta. Ancak bu bilgilerin dizilişi bizim çalışma sistemimiz ve tablolarımızla uyumsuzluk içermekte. Bu yüzden bu verileri 2. tabloda gösterildiği üzere düzenlemek istiyoruz.

Ben 10 kişilik bir örnek verdim. Ama tablomuzda ortalama 5.000 kişi var yardımcı olursanız sevinirim.

 

[Ferhat Pazarçevirdi]

Aşağıdaki kodu bir modül sayfasına kopyalayarak çalıştırınız.

Sub aktar()
Set shr = Sheets("REFERANS")
Set shs = Sheets("SIRALI")
sonr = shr.Cells(65536, 1).End(xlUp).Row
sons = shs.Cells(65536, 1).End(xlUp).Row
shs.Range("A3:F" & sons).ClearContents
For i = 3 To sonr
  sons = shs.Cells(65536, 1).End(xlUp).Row
     If shr.Cells(i, 2) <> "" Then
        shs.Cells(sons + 1, 1) = shr.Cells(i, 1)
        For j = 2 To 6
            shs.Cells(sons + 1, j) = shr.Cells(i, j)
        Next j
     End If
     
     If shr.Cells(i, 7) <> "" Then
        sons = shs.Cells(65536, 1).End(xlUp).Row
        shs.Cells(sons + 1, 1) = shr.Cells(i, 1)
        For j = 2 To 6
            shs.Cells(sons + 1, j) = shr.Cells(i, j + 5)
        Next j
     End If
     
      If shr.Cells(i, 12) <> "" Then
        sons = shs.Cells(65536, 1).End(xlUp).Row
        shs.Cells(sons + 1, 1) = shr.Cells(i, 1)
        For j = 2 To 6
            shs.Cells(sons + 1, j) = shr.Cells(i, j + 10)
        Next j
     End If
Next i
Set shr = Nothing
Set shs = Nothing
End Sub

 

[HAKANP]

Çok teşekkür eder, iyi çalışmalar dilerim