Sayfadaki belirli kriterlere uyan değerleri başka bir sayfaya taşıma

[sqoist]

Daha önce aynı dosya için koşullu biçimlendirme için yardım talebinde bulunmuştum onu çözdüm teşekkür ederim şimdi istediğim şey ise , birim maliyeti yüksek olan satıları özet adında bir sayfaya aktarmak istiyorum örneğin birin maliyeti 50 tl ve üstü

Şimdiden teşekkür ederim



Dosya

 

[hamitcan]

Pivot Table ile yapmayı denediniz mi ?

 

[sqoist]

yok denemedim pek bilgim olmadığı için o konuda biraz araştırayım teşekkür ederim

 

[sqoist]

Beceremedim pivot yapmayı yardımcı olacak olan var mı acaba

Teşekkür ederim şimdiden

 

[Necdet]

Bence Filtrelemeyi deneyin.
Aradaki boş satırları da silin.

 

[Necdet]

Dosyayı ekler misin bakalım

arkadaşımız dosyayı zaten eklemiş

 

[catalinastrap]

Konu bende Necdet Hocam

 

[catalinastrap]

Dosyanız Ektedir

 

[sqoist]

İndiremedim altın üyelik istiyor ama şimdi sizin de emeğinize yazık harici bir yere link ekleyin desem ben biraz çözmeye çalışayım.
yine de teşekkür ederim emekleriniz i.in.

 

[catalinastrap]

haftalik__1_.xlsm dosyasını indir - download

haftalik__1_.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[sqoist]

Kardeşim şimdi denedim çok işime yaradı ama son bir şey sormak istiyorum. Sayfa olarak değil de çalışma sayfası olarak yapabilme şansım var mı 7 gün için ayrı ayrı sayfam var ..

 

[Necdet]

Merhaba, İNCELEYİNİZ

 

[sqoist]

Sub CopyRowsBasedOnCriteria()
Dim wsSource As Worksheet
Dim wsSummary As Worksheet
Dim lastRow As Long
Dim i As Long
Dim summaryRow As Long

Set wsSource = ThisWorkbook.Sheets("26012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

Set wsSource = ThisWorkbook.Sheets("27012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

Set wsSource = ThisWorkbook.Sheets("28012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

Set wsSource = ThisWorkbook.Sheets("29012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

Set wsSource = ThisWorkbook.Sheets("30012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

Set wsSource = ThisWorkbook.Sheets("31012025")
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row
summaryRow = 1
For i = 1 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i
End Sub

Bu şekil çoğaltım ama bu seferde ilk makrodan sonra sayfa var hatası alıyorum ama bu manuel bir çözüm oluyor. aktar dediğimde 7 sayfayıda tek sayfada olsun istiyorum yapabilir miyiz

 

[sqoist]

Merhaba, İNCELEYİNİZ

tamam bakıyorum mesajınızı yeni gördüm teşekkür ederim

 

[sqoist]

tamam bakıyorum mesajınızı yeni gördüm teşekkür ederim

inceledim fakat benim istediğim sonuç bu değil ellerinize sağlık bu çalışma da çok iyi olmuş. Benim istediğim şu
catalinastrap arkadaşımızın yaptığı çalışma tek sayfada çok güzel oldu ben bunu tek makrado 7 sayfaya birden yapıp bulduğu maliyeti 50 den fazla olan malzemeleri bir sayfada toplamak

 

[sqoist]

Ne yaptıysam olmadı ayrı ayrı modül yapmaya çalıştım yine olmadı

 

[Necdet]

Sanırım ben yanlış anladım, yukarıda verdiğim link bu isteğinizi karşılamıyor.
7 sayfanın yapısı da aynı mı?

 

[Necdet]

Yanıt gelmedi.
Aşağıdaki kodlar sayfaların aynı yapıda olması ve sadece Özet ve veri sayfaların olması gerekir.

Özet sayfası yoksa oluşturunuz. Kodda bunları kontrol etmedim.

Sub Listele()

Dim sh  As Worksheet
Dim arr As Variant
Dim i   As Long
Dim j   As Long
Dim c   As Integer
Dim shO As Worksheet
Dim sut As Range

On Error Resume Next
Set sut = Application.InputBox("Hangi Sütunda İşlem Yapılacaksa O sütunu ya da o sütunda bir hücre seçiniz", "Sütun Seçimi", Range("H1").Address, Type:=8)

If sut Is Nothing Then
    MsgBox "Sütun Seçmediniz..."
    Exit Sub
End If

Set shO = Sheets("Özet")
shO.Cells.ClearContents

For Each sh In Worksheets
    If Not sh.Name = shO.Name Then
        i = sh.Cells(Rows.Count, "H").End(3).Row
        arr = sh.Range("A1:J" & i).Value
        j = 1
        For i = 2 To UBound(arr, 1)
            If arr(i, sut.Column) >= 50 Then
                j = j + 1
                For c = 1 To UBound(arr, 2)
                    arr(j, c) = arr(i, c)
                Next c
            End If
        Next i
        i = shO.Cells(Rows.Count, "F").End(3).Row + 2
        If i = 3 Then i = 1
        shO.Range("A" & i).Resize(j, UBound(arr, 2)) = arr
        If i > 1 Then shO.Rows(i).Delete
    End If
Next sh

With shO
    .Select
    .Cells.EntireColumn.AutoFit
End With
MsgBox "İşlem Tamamdır....."

End Sub

 

[sqoist]

Sanırım ben yanlış anladım, yukarıda verdiğim link bu isteğinizi karşılamıyor.
7 sayfanın yapısı da aynı mı?

EVET

 

[Necdet]

18 nolu mesajdaki kodları denediniz mi?