Standart olmayan excel kayıtlarını düzenli veri haline getirmek?

[inFiesta]

Merhabalar;
Konu başlığında çok iyi ifade edemedim kusura bakmayın. Ekteki dosyadan da inceleyebileceğiniz bir excel sayfam var. Benim bunu veritabanı haline getirmem gerekiyor. Örnekteki "sayfa1" sayfasında her bina için açılmış bir kayıt ve onun altında her daire ya da işyeri için açılmış alt kayıtlar var. Kimi binalardan tek bağımsız bölüm varken kiminde 1'den fazla kayıt var. Ben bunu sayfa2'de örneklediğim şekilde düzenli veri listesi haline getirmek istiyorum.Bu örnekteki gibi yüzlerce sayfa var. Manuel olarak tek tek yapabilmem mümkün değil. Formül ile alabilmek de pek mümkün görünmedi bana. Döngüler kullanılarak yapılabileceğini düşünüyorum. Belirli mantıklar kullanarak ilk ve son kayıtları buldum fakat nasıl bir döngü oluşturabileceğimi bilemedim. İncelerseniz sevinirim.

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

[Sub Listele()
Set s1 = Sheets("sayfa1")
Set s2 = Sheets("sayfa2")
s2.Range("a2:e65536").ClearContents
Application.ScreenUpdating = False
s1.Select
For i = 6 To s1.[b65536].End(3).Row
s1.Cells(i, "b").Select
If s1.Cells(i, "b").Value = "Nitelik Türü Detayı" Then
a = s1.Cells(i - 2, "a").Value
b = s1.Cells(i - 1, "a").Value
k = 0
Do While Not IsEmpty(ActiveCell)
k = k + 1
sat = s2.[a65536].End(3).Row + 1
s1.Cells(i + k, "b").Select
If s1.Cells(i + k, "b").Value <> "" Then
s2.Cells(sat, "a").Value = a
s2.Cells(sat, "b").Value = b
s2.Cells(sat, "c").Value = s1.Cells(i + k, "b").Value
s2.Cells(sat, "d").Value = s1.Cells(i + k, "c").Value
s2.Cells(sat, "e").Value = s1.Cells(i + k, "d").Value
End If
Loop
End If
Next i
s2.Select
Set s1 = Nothing
Set s2 = Nothing
Application.ScreenUpdating = True
MsgBox "Listeleme Tamamlandı.", vbInformation, "Bilgi"
End Sub

 

[inFiesta]

Recep Bey, ne kadar teşekkür etsem azdır. Çok sağolun ilgilendiğiniz için.

Ben kodları biraz daha değiştirerek 50 sayfalık bir belgedeki tüm sayfaları tek tıkla aktaracak çevirecek hale getirdim. İşlerimi inanılmaz kolaylaştırdı. Excel olmasa ne yapardık bilmiyorum )

 

[tahsinanarat]

sn. inFiesta değiştirdiğiniz o kodları da ekleyebilirmisiniz, incelemek isterdim.

 

[inFiesta]

sayın tahsinanarat kodlarım aşağıdaki şekilde değişti:
(kodların içerisinde gerekli açıklamaları yaptım; ekteki örnekten de deneyebilirsiniz)

Private Sub CommandButton1_Click()
For s = 1 To 5 'Buraya exceldeki sayfa sayımı ekledim
Set s1 = Sheets("Sheet" & s)
Set s2 = Sheets("data")
's2.Range("a2:e65536").ClearContents döngü her tekrarında bu alanı sileceği için bu satırı iptal etmem gerekti
Application.ScreenUpdating = False
s1.Select
For i = 6 To s1.[b65536].End(3).Row
s1.Cells(i, "b").Select
If s1.Cells(i, "b").Value = "Nitelik Türü Detayı" Then
a = s1.Cells(i - 2, "a").Value
b = s1.Cells(i - 1, "a").Value
c = s1.Cells(2, "a").Value ' her sayfamın başında a2 hücresindeki bilgileri de kayıtlarıma eklemek için bu kodu ekledim.
k = 0
Do While Not IsEmpty(ActiveCell)
k = k + 1
sat = s2.[a65536].End(3).Row + 1
s1.Cells(i + k, "b").Select
If s1.Cells(i + k, "b").Value <> "" Then
s2.Cells(sat, "a").Value = c
s2.Cells(sat, "b").Value = a
s2.Cells(sat, "c").Value = b
s2.Cells(sat, "d").Value = s1.Cells(i + k, "b").Value
s2.Cells(sat, "e").Value = s1.Cells(i + k, "c").Value
s2.Cells(sat, "f").Value = s1.Cells(i + k, "d").Value
End If
Loop
End If
Next i
s2.Select
Set s1 = Nothing
Set s2 = Nothing
Application.ScreenUpdating = True
Next 'döngü sonu
MsgBox "Listeleme Tamamlandı.", vbInformation, "Bilgi"
End Sub

 

[tahsinanarat]

sn. inFiesta çok teşekkür ederim. Sağolun.