Data ve Arabul sayfası formüllendirme

[maraslimesut46]

Merhaba sayın arkadaşlar; yapmaya çalıştığım olay şu:
1. Sayfa: DATA
2. Sayfa: ARABUL

Data sayfasında zimmetimde bulunan tüm sarf malzemelerim yer alıyor. Ben arabul sayfasında "Personel Üzerinde" dediğim zaman aşağıdaki tabloda data sayfasında karışık halde bulunan tabloda sadece personel üzerinde olan verileri çeksin istiyorum. veya "obüs" seçtiğimde tabloda obüs'e ait dolu olan verileri çeksin istiyorum. Bunu aynı sayfada filtreleme ile yapabiliyoruz. Ama ben böyle bir arama sayfası yapmak istiyorum. Malzeme listelerinin karşısına tek tek isim verip veri doğrulama ve makro ile personeli seçince zimmetlediğim listeyi çıkartan sayfayı yaptım. Ama böyle tek tek isim vermek gerekiyor. Ben depo yazınca depomdaki malzemeleri hemen başka bir personele değiştirmek istiyorum.

 

[maraslimesut46]

Örnek şablon olarak ekliyorum. Teşekkür ederim

 

[maraslimesut46]

Aşağıdaki kod ile çözdüm. teşekkür ederim.
Kodda: otomatik tablo oluşturma, otomatik sıra no ekleme mevcut. Arayan olursa diye buraya atıyorum.

Sub VerileriFiltreleVeKopyala()
    Dim wsData As Worksheet
    Dim wsArabul2 As Worksheet
    Dim aramaDegeri As String
    Dim sutunIndeksi As Integer
    Dim sonSatir As Long
    Dim i As Long
    Dim kopyalaSatir As Long
    Dim siraNo As Long

    ' Çalışma sayfalarını ayarla
    Set wsData = ThisWorkbook.Sheets("DATA")
    Set wsArabul2 = ThisWorkbook.Sheets("ARABUL2")

    ' ARABUL2 sayfasındaki A2 hücresindeki arama değerini al
    aramaDegeri = wsArabul2.Range("A2").Value

    ' Arama değerinin bulunduğu sütunu bul
    On Error Resume Next
    sutunIndeksi = Application.WorksheetFunction.Match(aramaDegeri, wsData.Range("G1:Y1"), 0)
    On Error GoTo 0

    ' Sütunun bulunup bulunmadığını kontrol et
    If sutunIndeksi = 0 Then
        MsgBox "Arama değeri bulunamadı. Lütfen A2 hücresine geçerli bir değer girin."
        Exit Sub
    End If

    ' Sütun indeksini G sütunundan başlayacak şekilde ayarla
    sutunIndeksi = sutunIndeksi + 6

    ' ARABUL2 sayfasını temizle
    wsArabul2.Range("A4:H1048576").Clear

    ' Başlıkları kopyala
    wsArabul2.Range("A4").Value = "SIRA NO"
    wsArabul2.Range("B4").Value = wsData.Range("A1").Value ' A1 başlık
    wsArabul2.Range("C4").Value = wsData.Range("B1").Value ' B1 başlık
    wsArabul2.Range("D4").Value = wsData.Range("C1").Value ' C1 başlık
    wsArabul2.Range("E4").Value = wsData.Range("D1").Value ' D1 başlık
    wsArabul2.Range("F4").Value = wsData.Range("E1").Value ' E1 başlık
    wsArabul2.Range("G4").Value = "DEĞER"

    ' Başlık satırını kalın ve 14 punto yap
    With wsArabul2.Range("A4:G4").Font
        .Bold = True
        .Size = 14
    End With

    ' Başlık satırını ortala
    wsArabul2.Range("A4:G4").HorizontalAlignment = xlCenter

    ' DATA sayfasındaki son satırı bul
    sonSatir = wsData.Cells(wsData.Rows.Count, 1).End(xlUp).Row

    ' Verileri kopyalamak için satırı başlat
    kopyalaSatir = 5
    siraNo = 1

    ' DATA sayfasında belirtilen sütundaki değerleri kontrol et ve 0'dan büyük olanları kopyala
    For i = 2 To sonSatir
        If wsData.Cells(i, sutunIndeksi).Value > 0 Then
            wsArabul2.Cells(kopyalaSatir, 1).Value = siraNo ' Sıra numarası
            wsArabul2.Cells(kopyalaSatir, 2).Value = wsData.Cells(i, 1).Value ' A sütunu değeri
            wsArabul2.Cells(kopyalaSatir, 3).Value = wsData.Cells(i, 2).Value ' B sütunu değeri
            wsArabul2.Cells(kopyalaSatir, 4).Value = wsData.Cells(i, 3).Value ' C sütunu değeri
            wsArabul2.Cells(kopyalaSatir, 5).Value = wsData.Cells(i, 4).Value ' D sütunu değeri
            wsArabul2.Cells(kopyalaSatir, 6).Value = wsData.Cells(i, 5).Value ' E sütunu değeri
            wsArabul2.Cells(kopyalaSatir, 7).Value = wsData.Cells(i, sutunIndeksi).Value ' Değer

            ' Tüm hücreleri ortala, sayı formatında biçimlendir ve metni kaydır
            With wsArabul2.Range(wsArabul2.Cells(kopyalaSatir, 1), wsArabul2.Cells(kopyalaSatir, 7))
                .HorizontalAlignment = xlCenter
                .NumberFormat = "0"
                .WrapText = True
            End With

            kopyalaSatir = kopyalaSatir + 1
            siraNo = siraNo + 1
        End If
    Next i

    ' Kenarlıkları çiz
    With wsArabul2.Range("A4:G" & kopyalaSatir - 1).Borders
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With

    ' Tüm hücrelerde metni kaydır
    wsArabul2.Range("A4:G" & kopyalaSatir - 1).WrapText = True

    MsgBox "Veriler filtrelendi ve başarıyla kopyalandı."
End Sub