İki farklı sayfadan verilerin süzülerek rapor sayfasına aktarılması

tufan03 · 12 Kasım 2007

Ekli dosyada bulunan dosyada ARŞİV sayfasındaki (F) sütununda bulunan tarihler esas alınarak günün tarihinden büyük olanlar süzülerek (GÜN) sayfasındaki tablonun tamamı süzülen bilgilerin altına eklenip rapor sayfasında gösterilmesi,rapor sayfasında birleştirilen tablonunda Userform üzerinde bir Listboxta görünmesini nasıl sağlayabiliriz. Selamlar.

Ferhat Pazarçevirdi · 12 Kasım 2007

Merhabalar

Aşağıdakli kodlar iki sayfadaki bilgileri birleştirerek, Rapor sayfasına aktaracaktır.

Kod:

Option Explicit
Sub deneme()
Dim shA As Worksheet, shR As Worksheet, shG As Worksheet
Dim arrArsivSatir()
Dim arrVeri()
Dim arrGun()
Dim x&, i&, j
Set shA = Sheets("ARŞİV")
Set shR = Sheets("rapor")
Set shG = Sheets("GÜN")
[COLOR=green]'Bugünden büyükler diziye çekiliyor-Arşiv sayfasından[/COLOR]
For i = 2 To shA.Cells(65536, 2).End(xlUp).Row
    If IsDate(shA.Cells(i, "F")) Then
       If shA.Cells(i, "F") > Date Then
          ReDim Preserve arrArsivSatir(x)
          arrArsivSatir(x) = i
          x = x + 1
       End If
    End If
Next i
ReDim arrVeri(1 To UBound(arrArsivSatir) + 1, 1 To 8)
For i = 1 To UBound(arrArsivSatir)
    For j = 1 To 8
        arrVeri(i, j) = shA.Cells(arrArsivSatir(i - 1), j + 1)
    Next j
Next i
[COLOR=green]'Gün sayfasındaki veriler alınıyor[/COLOR]
ReDim arrGun(1 To shG.Cells(65536, 2).End(xlUp).Row - 1, 1 To 8)
For i = 2 To shG.Cells(65536, 2).End(xlUp).Row
    For j = 1 To 8
        arrGun(i - 1, j) = shG.Cells(i, j + 1)
    Next j
Next i
[COLOR=green]'Rapor sayfasına veriler yazdırılıyor[/COLOR]
shR.Range("B2:I" & shR.Cells(65536, 2).End(xlUp).Row).ClearContents
shR.Range("B2").Resize(UBound(arrGun), 8) = arrGun
shR.Range("B" & UBound(arrGun) + 2).Resize(UBound(arrVeri), 8) = arrVeri
Set shA = Nothing
Set shR = Nothing
Set shG = Nothing
End Sub

Not : Örneğinizde userfom ve listbox tasarımları olmadığı için bu kısım es geçildi.

tufan03 · 12 Kasım 2007

Sayın fpc Kodun "ReDim arrVeri(1 To UBound(arrArsivSatir) + 1, 1 To 8)" satırında hata verdi.

Ferhat Pazarçevirdi · 12 Kasım 2007

Doğru söylüyorsunuz. Muhtemelen ARŞİV sayfasında Bugünün tarihinden büyük tarih değeri bulunmuyordur. Üstüne ben de kodlara hata kontrolünü yerleştirmeyince olacağı buydu.

Aşağıdaki kodları deneyin, lütfen

Kod:

Option Explicit
Sub deneme()
Dim shA As Worksheet, shR As Worksheet, shG As Worksheet
Dim arrArsivSatir()
Dim arrVeri()
Dim arrGun()
Dim x&, i&, j
Set shA = Sheets("AR&#350;&#304;V")
Set shR = Sheets("rapor")
Set shG = Sheets("G&#220;N")
shR.Range("B2:I" & shR.Cells(65536, 2).End(xlUp).Row).ClearContents
'G&#252;n sayfas&#305;ndaki veriler al&#305;n&#305;yor
If shG.Cells(65536, 2).End(xlUp).Row > 1 Then
   ReDim arrGun(1 To shG.Cells(65536, 2).End(xlUp).Row - 1, 1 To 8)
   For i = 2 To shG.Cells(65536, 2).End(xlUp).Row
       For j = 1 To 8
           arrGun(i - 1, j) = shG.Cells(i, j + 1)
       Next j
   Next i
End If
If shG.Cells(65536, 2).End(xlUp).Row > 1 Then
   shR.Range("B2").Resize(UBound(arrGun), 8) = arrGun
End If
'Bug&#252;nden b&#252;y&#252;kler diziye &#231;ekiliyor-Ar&#351;iv sayfas&#305;ndan
For i = 2 To shA.Cells(65536, 2).End(xlUp).Row
    If IsDate(shA.Cells(i, "F")) Then
       If shA.Cells(i, "F") > Date Then
          ReDim Preserve arrArsivSatir(x)
          arrArsivSatir(x) = i
          x = x + 1
       End If
    End If
Next i
If x > 0 Then
   ReDim arrVeri(1 To UBound(arrArsivSatir) + 1, 1 To 8)
   For i = 1 To UBound(arrArsivSatir) + 1
       For j = 1 To 8
           arrVeri(i, j) = shA.Cells(arrArsivSatir(i - 1), j + 1)
       Next j
   Next i
End If
'Rapor sayfas&#305;na veriler yazd&#305;r&#305;l&#305;yor
If x > 0 Then
   shR.Range("B" & shR.Cells(65536, 2).End(xlUp).Row + 1).Resize(UBound(arrVeri), 8) = arrVeri
End If
Set shA = Nothing
Set shR = Nothing
Set shG = Nothing
End Sub

tufan03 · 13 Kasım 2007

Sayın fpc iki gündür senin kodları kendime uyarlamaya çalışıyorum, öncelikle yanlış anlaşılma oldu,tabiki benim hatamdan ve izahatımdan kaynaklanıyor.
İşin aslı "GÜN" sayfasında da F sütunu esas alınarak günün tarihinden büyük olanlar süzülüp (Tamamı değil) rapor sayfasına yapıştırılması gerekiyordu. Ayrıca Rapor sayfasına gönderilen bilgilerin sütunlar halinde Listboxta gösterilmesini yapabilirsen makbule geçecek. Zahmet verdik,teşekkür ederim.

Ferhat Pazarçevirdi · 14 Kasım 2007

Bu prosedür oluşturulurken; sizin şu izahatınıza göre tek tek gidildi.

(1) Ekli dosyada bulunan dosyada ARŞİV sayfasındaki (F) sütununda bulunan tarihler esas alınarak

(2) günün tarihinden büyük olanlar süzülerek

(3) (GÜN) sayfasındaki tablonun tamamı süzülen bilgilerin altına eklenip

(4) rapor sayfasında gösterilmesi,

(5) rapor sayfasında birleştirilen tablonunda Userform üzerinde bir Listboxta görünmesini nasıl sağlayabiliriz

Şimdiki izahatınızda da ARŞİV sayfasından hiç bahsetmemektesiniz.

Sadece GÜN sayfasından, bugünden büyük tarihler süzülüp RAPOR sayfasına mı aktarılacak yani?

tufan03 · 14 Kasım 2007

Hem Arşiv hemde gün sayfasındaki F sütunları esas alınarak günün tarihinden büyükler süzülüp rapor sayfasında birleştirilecek.

Ferhat Pazarçevirdi · 14 Kasım 2007

O zaman, aşağıdaki kodu deneyin

Kod:

Option Explicit
Sub deneme()
Dim shA As Worksheet, shR As Worksheet, shG As Worksheet
Dim arrArsivSatir(), arrGunSatir()
Dim arrVeri()
Dim arrGun()
Dim x&, i&, j
Set shA = Sheets("ARŞİV")
Set shR = Sheets("rapor")
Set shG = Sheets("GÜN")
shR.Range("B2:I" & shR.Cells(65536, 2).End(xlUp).Row).ClearContents
[COLOR=darkgreen]'GÜN sayfasındaki, Bugünden büyük tarihler diziye çekiliyor[/COLOR]
For i = 2 To shG.Cells(65536, 2).End(xlUp).Row
    If IsDate(shG.Cells(i, "F")) Then
       If shG.Cells(i, "F") > Date Then
          ReDim Preserve arrGunSatir(x)
          arrGunSatir(x) = i
          x = x + 1
       End If
    End If
Next i
If x > 0 Then
   ReDim arrVeri(1 To UBound(arrGunSatir) + 1, 1 To 8)
   For i = 1 To UBound(arrGunSatir) + 1
       For j = 1 To 8
           arrVeri(i, j) = shG.Cells(arrGunSatir(i - 1), j + 1)
       Next j
   Next i
End If
[COLOR=darkgreen]'Rapor sayfasına veriler yazdırılıyor[/COLOR]
If x > 0 Then
   shR.Range("B" & shR.Cells(65536, 2).End(xlUp).Row + 1).Resize(UBound(arrVeri), 8) = arrVeri
End If
Erase arrVeri
x = 0
[COLOR=darkgreen]'-------------------------------------------
'ARŞİV sayfasındaki, Bugünden büyük tarihler diziye çekiliyor[/COLOR]
For i = 2 To shA.Cells(65536, 2).End(xlUp).Row
    If IsDate(shA.Cells(i, "F")) Then
       If shA.Cells(i, "F") > Date Then
          ReDim Preserve arrArsivSatir(x)
          arrArsivSatir(x) = i
          x = x + 1
       End If
    End If
Next i
If x > 0 Then
   ReDim arrVeri(1 To UBound(arrArsivSatir) + 1, 1 To 8)
   For i = 1 To UBound(arrArsivSatir) + 1
       For j = 1 To 8
           arrVeri(i, j) = shA.Cells(arrArsivSatir(i - 1), j + 1)
       Next j
   Next i
End If
[COLOR=darkgreen]'Rapor sayfasına veriler yazdırılıyor[/COLOR]
If x > 0 Then
   shR.Range("B" & shR.Cells(65536, 2).End(xlUp).Row + 1).Resize(UBound(arrVeri), 8) = arrVeri
End If
Set shA = Nothing
Set shR = Nothing
Set shG = Nothing
End Sub

tufan03 · 14 Kasım 2007

fpc çok teşekkür ederim. Kod çalıştığında rapor sayfasının başlıkları siliniyor,önemli değil işimiz zamanında görüldü yetiyor.

Ferhat Pazarçevirdi · 14 Kasım 2007

Başlıkların silinmemesi için, aşağıdaki satırları (kırmızı ile gösterilen) koda ilave etmek gerekir. Ben o zaman akıl edememişim

Kod:

Option Explicit
Sub deneme()
Dim shA As Worksheet, shR As Worksheet, shG As Worksheet
Dim arrArsivSatir(), arrGunSatir()
Dim arrVeri()
Dim arrGun()
Dim x&, i&, j
Set shA = Sheets("ARŞİV")
Set shR = Sheets("rapor")
Set shG = Sheets("GÜN")
[COLOR=red]if shR.Cells(65536,2).End(xlUp).Row>2 then[/COLOR]
   shR.Range("B2:I" & shR.Cells(65536, 2).End(xlUp).Row).ClearContents
[COLOR=red]End If[/COLOR]
'GÜN sayfasındaki, Bugünden büyük tarihler diziye çekiliyor
'....
'Diğer satırlar

İki farklı sayfadan verilerin süzülerek rapor sayfasına aktarılması

tufan03

Ferhat Pazarçevirdi

Özel Üye

tufan03

Ferhat Pazarçevirdi

Özel Üye

tufan03

Ferhat Pazarçevirdi

Özel Üye

tufan03

Ferhat Pazarçevirdi

Özel Üye

tufan03

Ferhat Pazarçevirdi

Özel Üye