Sayfa 1'de aranılan kriterlere göre sayfa 2'de listeleme..

[acemi74]

arkadaşlar aşağıdaki şekilde bir excel sayfam var....ben iki kişiyi yazdım ama 100'lerce isim var


A sütünu B SUTUNU
Adı ali
soyadı şakir
memleket bartın
cinsiyeti erkek
köyü hendek
ana adı melek
baba adı ismail
---------------------------
Adı veli
soyadı baybay
memleket malatya
cinsiyeti erkek
köyü cukurca
ana adı berna
baba adı mahmut.
...........................
.........................böyle devam ediyor...

sizden şöyle bir ricam var....
bu sayfadaki bilgileri 2. sayfaya şu şekilde yazdırabilirmiyiz..
A sütunu adı B sütunu soyadını c sutunu baba adını...temsil ettiğini düşünerek..

A sütünu B sütünu C sutunu
ali şakir ismail
veli baybay mahmut..
..... .......... .........
..... .......... .........

nasıl yapabilirim...

 

[Ömer]

Merhaba,

Sub Aktar()
Application.ScreenUpdating = False
Set S1 = Sheets("Sayfa2")
Sheets("Sayfa1").Select
S1.Range("A2:G65536").ClearContents
sat = 1
    For i = 1 To [A65536].End(3).Row Step 7
        sat = sat + 1
        Range(Cells(i, "b"), Cells(i + 6, "b")).Copy
          S1.Cells(sat, "a").PasteSpecial Paste:=xlPasteValues, _
          Operation:=xlNone, Transpose:=True
          Application.CutCopyMode = False
    Next i
S1.Columns("C:F").Delete Shift:=xlToLeft
Application.ScreenUpdating = True
End Sub

Bu şekilde deneyin. Dosyanıza uyarlayamazsanız küçük bir örnek ekleyerek açıklayınız.

Eğer veri bitişlerinde bir satır boşluk varsa,

For i = 1 To [A65536].End(3).Row Step 7

7 olan bölgeyi ilk yazdığım kodda 8 olarak değiştirin.

.

 

[acemi74]

öncelikle ilginize teşekkür ediyorum ömer bey....
sizin yazdığınız kodlar bir kişi için 7-8 satır için mesela kimi 6 satır kimi 10 satırsa bu kodlar bi işe yaramaz.. Bende bunu belirtmediğim için sizde ona göre kod yazdınız...
Bu yüzden size gerçek bir örnek gönderiyorum.....

tekrar ilgilenirseniz çok sevinirim...

 

[Ömer]

Merhaba,

Bu şekilde deneyin. İstediğiniz verileri Sayfa2 de listeler.

Sub Bul()
Set S1 = Sheets("Sayfa2")
S1.Range("A2:C65536").ClearContents
Sheets("Sayfa1").Select
sat1 = 1: sat2 = 1: sat3 = 1
    For i = 1 To [A65536].End(3).Row
        If Trim(Cells(i, "a")) = "File:" Then
            sat1 = sat1 + 1
            S1.Cells(sat1, "a") = Cells(i, "b")
        End If
        If Trim(Cells(i, "a")) = "Resolution:" Then
            sat2 = sat2 + 1
            S1.Cells(sat2, "b") = Cells(i, "b")
        End If
        If Trim(Cells(i, "a")) = "Number Of Copies:" Then
            sat3 = sat3 + 1
            S1.Cells(sat3, "c") = Cells(i, "b")
        End If
    Next i
End Sub

.

 

[acemi74]

ömer bey ilgi ve alakanıza çok teşekkür ediyorum...
Şu itibariyle fevkalade şekilde işimi gördü....

herhangi bir sorun yaşarsam tekrar rahatsız edebilirmiyim....

 

[acemi74]

        If Trim(Cells(i, "a")) = "Resolution:" Then
            sat2 = sat2 + 1
            S1.Cells(sat2, "b") = Cells(i, "b")
        End If

Yazdığınız kodlardaki bu bölümün karşılığı b sütünündaki ilgili hücreye şu şekillerde yazılıyor..

360x1440(4-8 Pass) veya 720x1440(3-6 Pass) veya 1440x360(3-6 Pass) vb....

Şu Şekilde yazdırma imkanımız varmı acaba...

e sütunu***** f sütünu *****g sütunu
360................1440............... (4-8 Pass)
720................1440................(3-6 Pass)
1440..............360..................(3-6 Pass) noktalar yok...

yani x'e kadar olan kısmı E sütununa
X'den sonraki kısmı paranteze kadar F sutununa
Parantezli kısmıda G sütununa nasıl yazdırabiliriz.....

 

[Ömer]

Merhaba,

Bu şekilde deneyin.

Sub Bul()
On Error Resume Next
Set S1 = Sheets("Sayfa2")
S1.Range("A2:G65536").ClearContents
Sheets("Sayfa1").Select
sat1 = 1: sat2 = 1: sat3 = 1: sat4 = 1: sat5 = 1: sat6 = 1
    For i = 1 To [A65536].End(3).Row
        If Trim(Cells(i, "a")) = "File:" Then
            sat1 = sat1 + 1
            S1.Cells(sat1, "a") = Trim(Cells(i, "b"))
        End If
        If Trim(Cells(i, "a")) = "Resolution:" Then
            sat2 = sat2 + 1
            S1.Cells(sat2, "b") = Trim(Cells(i, "b"))
        End If
        If Trim(Cells(i, "a")) = "Number Of Copies:" Then
            sat3 = sat3 + 1
            S1.Cells(sat3, "c") = Cells(i, "b")
        End If
    Next i
S1.Select
    For j = 2 To [A65536].End(3).Row
        sat4 = sat4 + 1
        Cells(sat4, "e") = Split(Cells(j, "b"), "x")(0)
        sat6 = sat6 + 1
        Cells(sat6, "g") = "(" & Split(Cells(j, "b"), "(")(1)
        sat5 = sat5 + 1
        Cells(sat5, "f") = Mid(Cells(j, "b"), Len(Cells(j, "e")) + 2, _
        Len(Cells(j, "b")) - Len(Cells(j, "g")) - Len(Cells(j, "e")) - 1)
    Next j
End Sub

.

 

[acemi74]

çok teşekkür ederim ömer bey .....