Döngülü Rapor

[Kemal Demir]

Arkadaslar Yeni başlık açmak istemezdim ama Ara Linki İçerisinde Ornek Bir Cozum bulamadığım için Başlık Actım.. Üzgünüm.

Elimde bir data var ve Capraz Sorgular ıceren bir durum

2 sheet'ten olusuyor Veri Þheet'ınde Dongulerın neler olduğunu yazdım

Data Sheet'ınde Elimdeki Datayı Yolladım. Aynı Anda Birden Fazla Koşul olduğundan Dolayı yetersız kaldım..

Yardımlarınıza İhtiyacım Var.
SaygıLar.

 

[Kemal Demir]

Arkadaslar Yoğunluğunuzun farkındayım musaıt zaman aralığında elimdeki probleme yardımcı olursanız sevınırım

 

[Kemal Demir]

Sıkboğazlık yapmak İstemiyorum ama
Zannedersem haklısınız.
Herkesın Ã?ncelikli İşleri var.

Sağlıcakla.

 

[veyselemre]

doğru anlamışmıyım

[vb:1:c378123515]Dim c As Integer
Sub bul()
Set s_v = Sheets("veri")
Set s_d = Sheets("data")


Dim adr(16, 2), par(15, 5)
adr(1, 1) = 1
adr(2, 1) = 1
adr(3, 1) = 1
adr(4, 1) = 1
adr(5, 1) = 9
adr(6, 1) = 9
adr(7, 1) = 9
adr(8, 1) = 9
adr(9, 1) = 17
adr(10, 1) = 17
adr(11, 1) = 17
adr(12, 1) = 17
adr(13, 1) = 25
adr(14, 1) = 25
adr(15, 1) = 25
adr(1, 2) = 2
adr(2, 2) = 6
adr(3, 2) = 10
adr(4, 2) = 14
adr(5, 2) = 2
adr(6, 2) = 6
adr(7, 2) = 10
adr(8, 2) = 14
adr(9, 2) = 2
adr(10, 2) = 6
adr(11, 2) = 10
adr(12, 2) = 14
adr(13, 2) = 2
adr(14, 2) = 6
adr(15, 2) = 10

For x = 1 To 15
For y = 1 To 5
par(x, y) = s_v.Cells(adr(x, 1), adr(x, 2)).Offset(y - 1, 0)
Next
Next
Dim hepsi(1000, 2)

For c0 = 1 To 15
ReDim bul1(1), bul2(1), bul3(1), bul4(1), bul5(1) As String

bul1(0) = par(c0, 1)
If InStr(par(c0, 1), " ve ") > 0 Then
bul11 = Split(par(c0, 1), " ve ")
Erase bul1
ReDim bul1(UBound(bul11))
For x = 0 To UBound(bul11)
bul1(x) = bul11(x)
Next
End If
For c1 = 0 To UBound(bul1)

bul2(0) = par(c0, 2)
If InStr(par(c0, 2), " ve ") > 0 Then
bul21 = Split(par(c0, 2), " ve ")
Erase bul2
ReDim bul2(UBound(bul21))
For x = 0 To UBound(bul21)
bul2(x) = bul21(x)
Next
End If
For c2 = 0 To UBound(bul2)

bul3(0) = par(c0, 3)
If InStr(par(c0, 3), " ve ") > 0 Then
bul31 = Split(par(c0, 3), " ve ")
Erase bul3
ReDim bul3(UBound(bul31))
For x = 0 To UBound(bul31)
bul3(x) = bul31(x)
Next
End If
For c3 = 0 To UBound(bul3)

bul4(0) = par(c0, 4)
If InStr(par(c0, 4), " ve ") > 0 Then
bul41 = Split(par(c0, 4), " ve ")
Erase bul4
ReDim bul4(UBound(bul41))
For x = 0 To UBound(bul41)
bul4(x) = bul41(x)
Next
End If
For c4 = 0 To UBound(bul4)

bul5(0) = par(c0, 5)
If InStr(par(c0, 5), " ve ") > 0 Then
bul51 = Split(par(c0, 5), " ve ")
Erase bul5
ReDim bul5(UBound(bul51))
For x = 0 To UBound(bul51)
bul5(x) = bul51(x)
Next
End If
For c5 = 0 To UBound(bul5)

If bul1(c1) <> "" And bul2(c2) <> "" And bul3(c3) <> "" And bul4(c4) <> "" And bul5(c5) <> "" Then
c = c + 1
hepsi(c, 1) = bul1(c1) & Chr(9) & bul2(c2) & Chr(9) & bul3(c3) & Chr(9) & bul4(c4) & Chr(9)
hepsi(c, 2) = bul5(c5)
End If

Next c5, c4, c3, c2, c1, c0
ReDim dizi(c, 2)
For x = 1 To c
dizi(x, 1) = hepsi(x, 1)
dizi(x, 2) = hepsi(x, 2)
Next

son_data = s_d.[a65536].End(3).Row

s_d.Range("f2:f" & son_data).ClearContents

For d = 2 To son_data
kont = ""
For g = 2 To 5
kont = kont & s_d.Cells(d, g) & Chr(9)
Next

For dd = 1 To c

If kont = dizi(dd, 1) Then
s_d.Cells(d, 6) = dizi(dd, 2)
Exit For
End If
Next
Next

End Sub[/vb:1:c378123515]

 

[Kemal Demir]

Sn Veysel Emre

gonderdiğim Excel sayfasında

*************************************
int01 1 ve5 ve -9998 b kolonu
int 11 c kolonu
int98 -9998 d kolonu
int99 -9998 E KOLONU
son durum 11 F KOLONU
**************************************

bu dongude int01 de yanlıs yazmısım yenı fark ettım
olması gereken değer

int01 1 ve5 ve b kolonu
int 11 c kolonu
int98 -9998 d kolonu
int99 -9998 E KOLONU
son durum 11 F KOLONU


dongude değişiklik yapacak seviyede değilim yardımcı olursanız sevınırım saygılar

 

[veyselemre]

yani b17 1 ve 5 mi demek
makronun işleyişi doğru mu

 

[Kemal Demir]

kesınlıkle tam anladığın gibi
mukemmel evet b17 sadece 1 ve 5 olacak

 

[veyselemre]

[vb:1:13161cf864]Dim c As Integer
Sub bul()
Set s_v = Sheets("veri")
Set s_d = Sheets("data")


Dim adr(16, 2), par(15, 5)
adr(1, 1) = 1
adr(2, 1) = 1
adr(3, 1) = 1
adr(4, 1) = 1
adr(5, 1) = 9
adr(6, 1) = 9
adr(7, 1) = 9
adr(8, 1) = 9
adr(9, 1) = 17
adr(10, 1) = 17
adr(11, 1) = 17
adr(12, 1) = 17
adr(13, 1) = 25
adr(14, 1) = 25
adr(15, 1) = 25
adr(1, 2) = 2
adr(2, 2) = 6
adr(3, 2) = 10
adr(4, 2) = 14
adr(5, 2) = 2
adr(6, 2) = 6
adr(7, 2) = 10
adr(8, 2) = 14
adr(9, 2) = 2
adr(10, 2) = 6
adr(11, 2) = 10
adr(12, 2) = 14
adr(13, 2) = 2
adr(14, 2) = 6
adr(15, 2) = 10

For x = 1 To 15
For y = 1 To 5
par(x, y) = s_v.Cells(adr(x, 1), adr(x, 2)).Offset(y - 1, 0)
Next
Next
Dim hepsi(1000, 2)

For c0 = 1 To 15
ReDim bul1(1), bul2(1), bul3(1), bul4(1), bul5(1) As String

bul1(0) = par(c0, 1)

If InStr(par(c0, 1), " ve ") > 0 Then
bul11 = Split(par(c0, 1), " ve ")
Erase bul1
ReDim bul1(UBound(bul11))
For x = 0 To UBound(bul11)
bul1(x) = bul11(x)
Next
End If
For c1 = 0 To UBound(bul1)

bul2(0) = par(c0, 2)
If InStr(par(c0, 2), " ve ") > 0 Then
bul21 = Split(par(c0, 2), " ve ")
Erase bul2
ReDim bul2(UBound(bul21))
For x = 0 To UBound(bul21)
bul2(x) = bul21(x)
Next
End If
For c2 = 0 To UBound(bul2)

bul3(0) = par(c0, 3)
For c3 = 0 To UBound(bul3)

bul4(0) = par(c0, 4)
For c4 = 0 To UBound(bul4)

bul5(0) = par(c0, 5)
For c5 = 0 To UBound(bul5)

If bul1(c1) <> "" And bul2(c2) <> "" And bul3(c3) <> "" And bul4(c4) <> "" And bul5(c5) <> "" Then
c = c + 1
hepsi(c, 1) = bul1(c1) & Chr(9) & bul2(c2) & Chr(9) & bul3(c3) & Chr(9) & bul4(c4) & Chr(9)
hepsi(c, 2) = bul5(c5)
End If

Next c5, c4, c3, c2, c1, c0
ReDim dizi(c, 2)
For x = 1 To c
dizi(x, 1) = Trim(hepsi(x, 1))
dizi(x, 2) = hepsi(x, 2)
Next

son_data = s_d.[a65536].End(3).Row

s_d.Range("f2:f" & son_data).ClearContents

For d = 2 To son_data
kont = ""
For g = 2 To 5
kont = kont & s_d.Cells(d, g) & Chr(9)
Next

For dd = 1 To c

If kont = dizi(dd, 1) Then
s_d.Cells(d, 6) = dizi(dd, 2)
Exit For
End If
Next
Next

End Sub[/vb:1:13161cf864]