Sayfalar da; istenen sütundaki verileri raporlama

[osmanli2]

Sayın üstatdlar, seçilen yıllar arasındaki sayfalarda 12 sylık sütünlarda istenen aya ait verilerin grup seçimine göre raporlanması konusunda yardınlarınızı rica ederim.

 

[mancubus]

dosya ektedir.

 

[osmanli2]

Sayfa ve sütunlarda istenen veriyi raporlama

sayın Mancubus, yardımlarınız ve emeğiniz için çok teşekkürler, fakat env sayfasında c sütunda =combobox4 e uyan A:b sütunlarında ki verileri raporlaması rica ediyorum. bu haliyle combobox şeçilen kriter haricindeki malzemelerde listeleniyor.

 

[mancubus]

deneyerek eklemiştim ama biraz daha sağlam hale getirdim.

problem çıkarsa tekrar bakarız.


uf'un kod modülündeki ilgili kodu silerek yerine aşağıdakini kopyalayalım.

Private Sub CommandButton1_Click()

Dim ws As Worksheet, wsRap As Worksheet, wsEnv As Worksheet
Dim sutBul As Range, rngEnv As Range
Dim ssat As Long, sat As Long, sut As Long, ssRap As Long
Dim basYil, bitYil, ayKrit, grKrit

With Application
    .DisplayAlerts = False
    .EnableEvents = False
    .ScreenUpdating = False
    Calc = .Calculation
    .Calculation = xlCalculationManual
End With

Set wsRap = Worksheets("rapor")
Set wsEnv = Worksheets("env")
basYil = CLng(ComboBox1.Value)
bitYil = CLng(ComboBox2.Value)
ayKrit = ComboBox3.Value & " Mik."
grKrit = ComboBox4.Value

With wsRap
    ssRap = .Cells(Rows.Count, "A").End(xlUp).Row
    If ssRap = 1 Then ssRap = 2
    .Range("A2:H" & ssRap).Clear
End With

For Each ws In Worksheets
    With ws
        If .Name <> "rapor" And .Name <> "env" Then
            If CLng(.Name) >= basYil And CLng(.Name) <= bitYil Then
                ssat = .Cells(.Rows.Count, "A").End(xlUp).Row
                On Error Resume Next
                Set sutBul = .Rows(1).Find(ayKrit)
                If Not sutBul Is Nothing Then sut = sutBul.Column
                For sat = 2 To ssat
                    ssRap = wsRap.Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).Row
                    Set rngEnv = wsEnv.Columns("A:A").Find(.Cells(sat, 1).Value)
                    If Not rngEnv Is Nothing Then
                        If rngEnv.Offset(0, 2) = grKrit Then
                            Range(.Cells(sat, 1), .Cells(sat, 3)).Copy Destination:=wsRap.Cells(ssRap, "A")
                            Range(.Cells(sat, sut), .Cells(sat, sut + 2)).Copy Destination:=wsRap.Cells(ssRap, "D")
                            wsRap.Cells(ssRap, "G") = .Name
                            wsRap.Cells(ssRap, "H") = ComboBox3.Value
                        End If
                    End If
                Next
                On Error GoTo 0
            End If
        End If
    End With
Next

With Application
     .DisplayAlerts = True
     .EnableEvents = True
     .ScreenUpdating = True
     .Calculation = Calc
End With

MsgBox "Kayıtlar aktarıldı!"
Unload UF_Rapor

End Sub

 

[osmanli2]

Mükemmel çalışışıyor.Hiç bir sorun yok.Elinize ve emeğinize sağlık. Çok teşekkür ederim.

 

[mancubus]

rica ederim.