Çek takip tablosundan rapor sayfasına veri aktarımı

[hurkanpisirici]

Merhaba

çek takip sayfama çek bilgilerimi giriyorum.Yapmak istediğim,
rapor sayfasındaki b1 hücresine firma ismi girdiğim zaman, o firmaya ait çekleri rapordaki kriterlere göre listelemesi.

mesela a firması yazdım portföyde tl ise portföy tl bölümüne
yada b firması tahsildeki usd bölümüne gibi,
rapora bakınca sorum anlaşılır hale gelecektir.

Hocalarımdan yardım bekliyorum.Teşekkürler

 

[hurkanpisirici]

Fonksiyonla olabilirmi bilmiyorum?

 

[mesuttasar]

Aşağıdaki gibi bir kod işinize yarar sanırım.

Sub deneme()
Set s1 = Sheets("rapor")
x = s1.[b1]
    Sheets("VERİ").Select
    Range("A1:I1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$I$4").AutoFilter Field:=1, Criteria1:=x
  Sheets("VERİ").Select
 y = [a65536].End(3).Row
 For i = 2 To y
 a = Cells(i, 5)
 b = Cells(i, 6)
 c = a & " " & b
  s1.Select
     For j = 5 To [a65536].End(3).Row
    d = Cells(j, 1).Value
     If d = c Then
      Sheets("VERİ").Select
     Range("A" & i & ":I" & i).Select
     Selection.Copy
     s1.Select
     Cells(j + 2, 1).Select
     ActiveSheet.Paste
        End If
     Next j
  Next i
  End Sub

 

[hurkanpisirici]

Sayın mesuttasar ilginize teşekkür ederim kodunuzu bir düğmeye atadım ve çalıştırdım rapor sayfasına sadece portföy olanı attı yani tahsildeki aynen yerinde kaldı bide atmaması gerekiyor rapaora ilava etmesi gerekiyor yani bilgiler veri sayfasında kalmalı.

 

[hurkanpisirici]

Bu çalışma benim için gerçekten çok önemli

 

[hurkanpisirici]

Elimdeki bütün örneklere baktım uyarlayamıyorum hiçbir şekilde, müsait olan bir arkadaş varmı acaba?

 

[hurkanpisirici]

Azimle beklemekteyim

 

[hurkanpisirici]

ilk defa cevapsız kaldım

 

[mesuttasar]

Sayın mesuttasar ilginize teşekkür ederim kodunuzu bir düğmeye atadım ve çalıştırdım rapor sayfasına sadece portföy olanı attı yani tahsildeki aynen yerinde kaldı bide atmaması gerekiyor rapaora ilava etmesi gerekiyor yani bilgiler veri sayfasında kalmalı.

Hürkan bey ,
veri sayfasındaki bilgiler aynen kalıyor da örneğin A FİRMASININ her iki çekini değilde sadece birini rapor sayasına aldı.Neden böyle oldu bende anlamadım doğrusu oysaki for next döngüsü ile her ikisinide alması gerekiyordu.

Bende çıkamadım içinden doğrusu.
Uzmanlarımızın el atması lazım

 

[hurkanpisirici]

mesut bey kafayı yiyorum bende dün geceden beri yapamıyorum

 

[hurkanpisirici]

ana sayfada gözükmesi için bir daha yazmak zorundayım belki ilgilenecek bir hocam çıkar.

 

[mesuttasar]

ana sayfada gözükmesi için bir daha yazmak zorundayım belki ilgilenecek bir hocam çıkar.

Hürkan bey , müjde yapabildim nihayet :icelim:
Biraz acemice oldu ama idare et artık eminim uzmanlarımız aynı işlemi 10 satırda da halledebilirler.
Kod'ları da yazayım.

Sub Makro1()
Application.ScreenUpdating = False
On Error Resume Next
Dim c As String
Set s1 = Sheets("rapor")
s1.Select
For M = 7 To 42 Step 7
Rows(M).Select
Selection.ClearContents
Next M


x = s1.[b1]
    Sheets("VERİ").Select
    Range("A1:I1").Select
    Selection.AutoFilter
    Range("A1:I1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$I$4").AutoFilter Field:=1, Criteria1:=x

 Sheets("VERİ").Select
 y = [a65536].End(3).Row
 
 For i = 2 To y Step 1
    Sheets("VERİ").Select
    c = Cells(i, 5) & " " & Cells(i, 6)
 
    s1.Select
    b = [a65536].End(3).Row
       For j = 5 To b Step 7
   
        If Cells(j, 1) = c Then
     
      Sheets("VERİ").Select
      Rows(i).Select
      Selection.Copy
      Sheets("RAPOR").Select
      Cells(j + 2, 1).Select
      ActiveSheet.Paste
      Application.CutCopyMode = False
        
       End If
      Next j
  Next i
 Sheets("VERİ").Select
 Range("A1:I1").Select
 Selection.AutoFilter
 Sheets("RAPOR").Select
 [B2].Select
  MsgBox "İşlem Tamamlanmıştır..."
End Sub

Örnek dosyayıda ekliyorum.İyi çalışmalar.

 

[hurkanpisirici]

mesut bey uğraş verdiğiniz için çok teşekkür ederim sizden başka yardım eden olmadı gerçekten çok sağolun.Dosyayı inceledim ama ne yazıkki olmadı mesela 3 tane çek yazdım 3 de aynı özelliktte ama sadece 1 tanesini attı

 

[hurkanpisirici]

neden olmadığını da çözemedim bir de rapor sayfasına gidecek bilgiler tamamen değişken yanim hangi bölüme kaş adet çek bilgisinin gideceği değişiyor sabit bir tablo olmayacak yani.

 

[osmanli2]

excel de rapor sayfası

"rapor" sayfasındaki b2 hücresindeki değere göre "param" sayfasındaki bilgileri tümünü (biçimleri ile birlikte) b7 hücresinden başlayarak "rapor" sayfasın da listeyen ve aynı şekilde "rapor1" sayfasında sadece renksiz değerleri listeleyen kodlara ihtiyacım var.yardımlarınız için çok teşekkürler.

 

[mesuttasar]

Kodlarda kırmızı renkli kısımlarda ilaveler yaptım umarım bu sefer istediğiniz gibi olmuştur.

Sub Makro1()
Application.ScreenUpdating = False
On Error Resume Next
Dim c As String
Set s1 = Sheets("rapor")
s1.Select
[COLOR=Red]Rows("2:45").Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select[/COLOR]
For m = 7 To 42 Step 7
Rows(m).Select
Selection.ClearContents
[COLOR=Red]Rows(m + 1).Select
Selection.ClearContents
Rows(m + 2).Select
Selection.ClearContents[/COLOR]
Next m


x = s1.[b1]
    Sheets("VERİ").Select
 Range("A1:I1").Select
    Selection.AutoFilter
    Range("A1:I1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$I$4").AutoFilter Field:=1, Criteria1:=x

 Sheets("VERİ").Select
 y = [a65536].End(3).Row
 
 For i = 2 To y Step 1
 Sheets("VERİ").Select
 c = Cells(i, 5) & " " & Cells(i, 6)
 
  s1.Select
  b = [a65536].End(3).Row
    For j = 5 To b Step 7
   
     If Cells(j, 1) = c Then
     
      Sheets("VERİ").Select
  Rows(i).Select
     Selection.Copy
    Sheets("RAPOR").Select
     Cells(j + 2, 1).Select
     [COLOR=Red]If Cells(j + 2, 1).Value = "" Then
     ActiveSheet.Paste
     Application.CutCopyMode = False
        Else:
        ActiveCell.Offset(1, 0).Select
        ActiveSheet.Paste
     Application.CutCopyMode = False
     
     End If[/COLOR]
 End If

 Next j
 Next i
  
 Sheets("VERİ").Select
 Range("A1:I1").Select
    Selection.AutoFilter
 Sheets("RAPOR").Select
 [B2].Select
 
 MsgBox "İşlem Tamamlanmıştır..."
End Sub

 

[mesuttasar]

Hürkan bey az kaldı biraz daga uğraşırsam olacak.Üstteki mesajı dikkate almayın.

 

[mesuttasar]

Sanırım bu defa oldu :biggrin:

Benim gibi br acemiyi çok uğraştırdı ama inşallah istediğiniz gibi olmuştur Hürkan Bey.
İyi çalışmalar,

NOT: Butona tıkladığınızda Seçili sayfayı silmeyle ilgili bir uyarı çkacak siz tamam diyin.Bu uyarının çıkmasının sebebi ABC isimli bir sayfa oluşturdum kodların içinde , işi bittiğinde o sayfayı silerken bu uyarı çıkıyor.Aklınızı karıştırmasın.

Sub Makro1()
Application.ScreenUpdating = False
On Error Resume Next
Dim c As String
'sayfa kopyalama modülü
Sheets("VERİ").Select
b = [a65536].End(3).Row
    Range("A1:I" & b).Select
    Selection.Copy
    Sheets.Add After:=Sheets(Sheets.Count)
    ActiveSheet.Name = "ABC"
    Range("A1").Select
    ActiveSheet.Paste
    Sheets("VERİ").Select
    Range("A1").Select
    Application.CutCopyMode = False
' sayfa kopyalama modül sonu
Set s1 = Sheets("rapor")
s1.Select
Rows("2:45").Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
For m = 7 To 42 Step 7
Rows(m).Select
Selection.ClearContents
Rows(m + 1).Select
Selection.ClearContents
Rows(m + 2).Select
Selection.ClearContents
Next m
x = s1.[B1].Value
  Sheets("VERİ").Select
 c = [a65536].End(3).Row
 For i = c To 2 Step -1
 Z = Cells(i, 1).Value
  If Z <> x Then
 Rows(i).Select
 Selection.EntireRow.Delete
 [a1].Select
 End If
  Next i
  y = [a65536].End(3).Row
 For i = 2 To y Step 1
 Sheets("VERİ").Select
 c = Cells(i, 5) & " " & Cells(i, 6)
   s1.Select
  b = [a65536].End(3).Row
    For j = 5 To b Step 7
       If Cells(j, 1) = c Then
       Sheets("VERİ").Select
  Rows(i).Select
     Selection.Copy
    Sheets("RAPOR").Select
     Cells(j + 2, 1).Select
     If Cells(j + 2, 1).Value = "" Then
     ActiveSheet.Paste
     Application.CutCopyMode = False
        Else:
        ActiveCell.Offset(1, 0).Select

[COLOR=Red][B]' İLAVE KOD EKLEDİĞİM SATIR[/B][/COLOR]

        ActiveSheet.Paste
     Application.CutCopyMode = False
          End If
 End If
  Next j
 Next i
 'abc sayfası kopyalama
Sheets("ABC").Select
    Selection.Copy
    Sheets("VERİ").Select
    [a1].Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=True, Transpose:=False
    Range("A1:I1").Select
    Application.CutCopyMode = False
    Sheets("RAPOR").Select
 [B2].Select
 Rows("2:45").Select
    Selection.EntireRow.Hidden = False
    Range("A1").Select
    Sheets("ABC").Select
    ActiveWindow.SelectedSheets.Delete
    Range("A1").Select
  MsgBox "Nihayet İşlem Tamamlanmıştır... :) "
End Sub

 

[hurkanpisirici]

Sayın mesut bey sizi uğraştırdığım için çok özür dilerim, uğraşınız için çok teşekkür edeirm.
Fakat eklediğiniz dosyada bütün çekleri aynı özellikta yaptım sadece ikisini attı bunun nedenini çözmiyorum bende emeğinize sağlık bu ilginiz bile yeter çok sağolun.Olmamış demek saygızılık gibi geliyor üzülüyorum bende.

 

[mesuttasar]

Sayın mesut bey sizi uğraştırdığım için çok özür dilerim, uğraşınız için çok teşekkür edeirm.
Fakat eklediğiniz dosyada bütün çekleri aynı özellikta yaptım sadece ikisini attı bunun nedenini çözmiyorum bende emeğinize sağlık bu ilginiz bile yeter çok sağolun.Olmamış demek saygızılık gibi geliyor üzülüyorum bende.

If ActiveCell.Value <> "" Then
        ActiveCell.Offset(1, 0).Select
        End If

Dostum saygısızlık olmaz olmamış demeniz , estağfurulah zaten çok iyi bildiğimide iddia etmiyorum. Yukarıdaki kodları 2 üst mesajımda İLAVE KOD SATIRI yazan yere , bu mesajda yazdığım kodu ilave edince inşallah bu sefer olmuştur diyorum.

İncelerseniz sevinirim.