Soldaki sayfalardan istenen verileri toparlamak

[necip54]

Herkeze iyi günler,
Yazmaya çalıştığım bir makroyu bitiremedim. Problem şöyle:
Bir çalışma kitabında 4 sayfa var ve ilk 3 sayfada girilen verilere göre bazı hesaplamalar yapılıyor. sayfa 4 e de, soldaki sayfalardaki bu verilerin bir şekilde aranılıp, alınıp, sayfa 4 de belirtilen yerlere alt alta yazdırılması gerekiyor.

sayfa 4 de b5:l18 arası seçilip temizlenecek.
sayfa 4 de a4 hucresine yazılacak isim ve soyad, soldaki bütün sayfalarda b4:b29 arasında aranacak, bu ismin karşısındaki satırda q,r,s,t,u,v,w,x,y,z,aa kolonlarındaki değerleri alıp sayfa 4 de b,c,d,e,f,g,h,ı,j,k,l sütunlarına 5.satırdan başlayıp alt alta sıralayacak.

Ben soldaki sayfaları tarattırma ve buldurma işine kadar makroyu yazdığımı zannediyorum fakat sayfa 4 e getirtip yazdıramadım.

Sub arabul()
Dim a As String
Dim i As Integer
Dim y As Range
Range("b5:l18").ClearContents
'B5:L18' ARASINI TEMİZLER'
a = ActiveSheet.Range("a4")
For i = 1 To Worksheets.Count
'SOL BAÞTAN İTİBAREN BÜTÜN SAYFALARI TARAR'
For Each y In Worksheets(i).Range("B4:B29")
'sayfa 2 de A4 E YAZILAN İSİME GÃ?RE HER SAYFADA B4:A29 ARASI LİSTEYİ GÃ?ZDEN GEÇİRİR'
If Trim = Trim(a) Then

bundan sonrasınında tıkandım.

örnek dosya eklidir.
yardımcı olacaklara şimdiden teşekkür ederim.

necip54

 

[necip54]

Sebebini bilmiyorum ama dosyayı ekleyemedim

necip54

 

[Levent Menteşoğlu]

Dosyanızı zipli olarak ekleyin.

 

[necip54]

Sn. leventm, Daha önce ekleyemediğim örnek dosya zipli olarak eklenmiştir.
Teşekkürler
necip54

 

[enderturk]

merhaba
aşağıdaki kodu denermisin
deneme fırsatım olmadı


Sub arabul()
Dim a As String
Dim i As Integer
Dim bak As Range
Range("b5:l18").ClearContents
a = ActiveSheet.Range("a4")
c=5
For i = 1 To Worksheets.Count -1
Sheets(i).select
For Each bak In Range("B4:B29")
If StrConv(bak.Value, vbUpperCase) = StrConv(a.Value, vbUpperCase) Then
bak.Select
Sheets(4).Cells(c,2).value = ActiveCell.Offset(0, 15).Value
Sheets(4).Cells(c,3).value = ActiveCell.Offset(0, 16).Value
Sheets(4).Cells(c,4).value = ActiveCell.Offset(0, 17).Value
Sheets(4).Cells(c,5).value = ActiveCell.Offset(0, 18).Value
Sheets(4).Cells(c,6).value = ActiveCell.Offset(0, 19).Value
Sheets(4).Cells(c,7).value = ActiveCell.Offset(0, 20).Value
Sheets(4).Cells(c,8).value = ActiveCell.Offset(0, 21).Value
Sheets(4).Cells(c,9).value = ActiveCell.Offset(0, 22).Value
Sheets(4).Cells(c,10).value = ActiveCell.Offset(0, 23).Value
Sheets(4).Cells(c,11).value = ActiveCell.Offset(0, 24).Value
Sheets(4).Cells(c,12).value = ActiveCell.Offset(0, 25).Value
c=c+1
End If
Next bak

Next i
End Sub

 

[necip54]

Sn.enderturk, işyerinde son beş dakikada denedim ama çalışmadı veşu satırda tutukluk yaptı
If StrConv(bak.Value, vbUpperCase) = StrConv(a.Value, vbUpperCase) Then

a harfinin üzrinde durup kalıyor.

Pazartesi günü yeniden deneyip hangi hata verdiğini iyice araştıracağım.

teşekkürler

 

[necip54]

Sn.enderturk, kodlarınızda bu çalışmayan satır olan
If StrConv(bak.Value, vbUpperCase) = StrConv(a.Value, vbUpperCase) Then

de tam olarak ne yapmak istediğinizi anlıyamadım, büyük,küçük harf ayrımıyla bir kısıtlama mı getiriyor?(ben kod yazmada sizin kadar ileri değilim)

 

[necip54]

Sn.enderturk
makro çalıştırıldığında
If StrConv(bak.Value, vbUpperCase) = StrConv(a.Value, vbUpperCase) Then

satırında a nın üzerine takılıp şu hatayı veriyor:

complie error:
invalid qualifier

necip54

 

[necip54]

Sn enderturk,
Makroyu aşağıdaki gibi düzenledim ve çalıştı.
Sub arabul()
Dim a As String
Dim i As Integer
Dim y As Range
Range("b5:l18").ClearContents
a = ActiveSheet.Range("a4")
For i = 1 To Worksheets.Count
For Each y In Worksheets(i).Range("B4:B29")
If Trim = Trim(a) Then
q = WorksheetFunction.CountA(ActiveSheet.Range("b4:b25")) + 5
ActiveSheet.Cells(q, 2).Value = y.Offset(aa, 15).Value
ActiveSheet.Cells(q, 3).Value = y.Offset(aa, 16).Value
ActiveSheet.Cells(q, 4).Value = y.Offset(aa, 17).Value
ActiveSheet.Cells(q, 5).Value = y.Offset(aa, 18).Value
ActiveSheet.Cells(q, 6).Value = y.Offset(aa, 19).Value
ActiveSheet.Cells(q, 7).Value = y.Offset(aa, 20).Value
ActiveSheet.Cells(q, 8).Value = y.Offset(aa, 21).Value
ActiveSheet.Cells(q, 9).Value = y.Offset(aa, 22).Value
ActiveSheet.Cells(q, 10).Value = y.Offset(aa, 23).Value
ActiveSheet.Cells(q, 11).Value = y.Offset(aa, 24).Value
ActiveSheet.Cells(q, 12).Value = y.Offset(aa, 25).Value

End If
Next
If Worksheets(i).Name = ActiveSheet.Name Then Exit Sub
Next
End Sub