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

[tufan03]

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]

Merhabalar

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

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]

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

 

[Ferhat Pazarçevirdi]

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

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")
shR.Range("B2:I" & shR.Cells(65536, 2).End(xlUp).Row).ClearContents
'Gün sayfasındaki veriler alını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ünden büyükler diziye çekiliyor-Arşiv sayfası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ına veriler yazdırılı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]

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]

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]

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]

O zaman, aşağıdaki kodu deneyin

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]

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]

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

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