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

[catalinastrap]

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

aşağıdaki kod işinizi çözecektir

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

Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
summaryRow = 1
headerCopied = False


For Each wsSource In ThisWorkbook.Sheets

If wsSource.Name <> "Özet Sayfa" Then
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

If Not headerCopied Then
wsSource.Rows(1).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
headerCopied = True
End If
For i = 2 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 If
Next wsSource
End Sub

 

[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]

18 nolu mesajdaki kodları denediniz mi?

denedim olmadı kardeşim ya

 

[Necdet]

denedim olmadı kardeşim ya

olması gereken sayfaları söylemiştim. Dosyanızı yükleyin neden olmadığını anlayalım.

 

[sqoist]

aşağıdaki kod işinizi çözecektir

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

Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
summaryRow = 1
headerCopied = False


For Each wsSource In ThisWorkbook.Sheets

If wsSource.Name <> "Özet Sayfa" Then
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

If Not headerCopied Then
wsSource.Rows(1).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
headerCopied = True
End If
For i = 2 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 If
Next wsSource
End Sub

Kardeşim ellerin kolların dert görmesin çok iyi olmuş bir şey daha isteyeceğim ama kusura bakma aynı modülde günler arasında boşluk koydura bilir misin acaba?

 

[sqoist]

olması gereken sayfaları söylemiştim. Dosyanızı yükleyin neden olmadığını anlayalım.

Tekrar deneyeceğim bilgilendirme için size de çok zahmet veriyorum catalinastrap arkadaşımızın yaptığı çalıştı

 

[catalinastrap]

Kardeşim ellerin kolların dert görmesin çok iyi olmuş bir şey daha isteyeceğim ama kusura bakma aynı modülde günler arasında boşluk koydura bilir misin acaba?

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

Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
summaryRow = 1
headerCopied = False

For Each wsSource In ThisWorkbook.Sheets
If wsSource.Name <> "Özet Sayfa" Then
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

If Not headerCopied Then
wsSource.Rows(1).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
headerCopied = True
End If
For i = 2 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

summaryRow = summaryRow + 1
End If
Next wsSource
End Sub

 

[sqoist]

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

Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
summaryRow = 1
headerCopied = False

For Each wsSource In ThisWorkbook.Sheets
If wsSource.Name <> "Özet Sayfa" Then
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

If Not headerCopied Then
wsSource.Rows(1).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
headerCopied = True
End If
For i = 2 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1
End If
Next i

summaryRow = summaryRow + 1
End If
Next wsSource
End Sub

Bu çok iyi oldu ama başlıklar kayboldu kardeşim ya .

 

[catalinastrap]

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

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

 

[Necdet]

Kodda dosyadaki boş satırları dikkate almadan işlem yaptırmışım.
Yukarıda verdiğim kodu düzenledim.
Dosyaya Ulaşmak İçin TIKLAYINIZ

Kodların hızlı çalıştığını göreceksiniz.

 

[sqoist]

Diyelim ki söyle bir şey yapmak istesem ayrı bir modül de de adet 50 den fazla olanları listelesem nasıl yaparım acaba.

 

[Necdet]

Merhaba,
18 Nolu Mesajda kodu güncelledim. Hangi sütunda işlem yapacaksanız o sütunu seçtiren kodu ekledim.

 

[sqoist]

günaydın , tamam kardeşim teşekkür ederim

 

[sqoist]

Böyle bir hata almaya başladım neden acaba..



resim hata

 

[catalinastrap]

Hatanın Ne olduğunu anlamadım tam olarak anlayamadım.

 

[sqoist]

sizin yaptığınız aktarma kodu vardı ya 50 tl den yukarı olan aktar a tıkladığım zaman iki satır aşağıdan başlayıp üst başlık olan doktor hasta sütünü alt alta iki kez yazıp sonra listeliyor.

 

[catalinastrap]

dosyanın son halini ekleyebilir misin bakayım tekrar.

 

[catalinastrap]

aşağıdaki gibi düzenledim kodu modüle kopyalayıp tekrar çalıştırır mısınız


Sub CopyRowsBasedOnCriteria()

Sheets("Özet Sayfa").Select
ActiveWindow.SelectedSheets.Delete

Dim wsSource As Worksheet
Dim wsSummary As Worksheet
Dim lastRow As Long
Dim i As Long
Dim summaryRow As Long

' Özet sayfasını oluştur ve adını "Özet Sayfa" olarak ayarla
Set wsSummary = ThisWorkbook.Sheets.Add
wsSummary.Name = "Özet Sayfa"
summaryRow = 1

For Each wsSource In ThisWorkbook.Sheets
' "Özet Sayfa" hariç tüm sayfalarda işlemi gerçekleştir
If wsSource.Name <> "Özet Sayfa" Then
lastRow = wsSource.Cells(wsSource.Rows.Count, "H").End(xlUp).Row

' Her sayfanın başlık satırını kopyala
wsSource.Rows(1).Copy wsSummary.Rows(summaryRow)
summaryRow = summaryRow + 1

' Kriteri sağlayan satırları kopyala
For i = 2 To lastRow
If wsSource.Cells(i, 8).Value >= 50 Then
' A sütunundaki hücreyi de kopyalayarak yeni satıra ekle
wsSource.Rows(i).Copy wsSummary.Rows(summaryRow)
wsSummary.Cells(summaryRow, 1).Value = wsSource.Cells(i, 1).Value
summaryRow = summaryRow + 1
End If
Next i

summaryRow = summaryRow + 1
End If
Next wsSource
End Sub

 

[sqoist]

Dosyayı ekledim
Dosya

 

[Necdet]

Her ne kadar bizim kodlarla ilgilenilmese de, ben yine de kodları ekleyim.

DOSYA

Public Sub Listele()

Dim col As Integer
Dim arr As Variant
Dim shL As Worksheet
Dim i   As Long
Dim j   As Long
Dim c   As Integer
Dim sh  As Worksheet

If SayfaVar("LİSTE") = False Then
    Worksheets.Add Before:=Sheets(1)
    ActiveSheet.Name = "LİSTE"
End If

Set shL = Sheets("LİSTE")

shL.Cells.ClearContents

If Application.Caller = "Düğme 1" Then
    col = 8
    shL.Range("A1") = "MALİYET 50 +"
Else
    col = 9
    shL.Range("A1") = "ADET 50 +"
End If

With shL.Range("A1")
    .Font.Size = 20
    .Font.ColorIndex = 3
End With

For Each sh In Worksheets
    If Not sh.Name = "LİSTE" And Not sh.Name = "ÖZET" Then
        i = sh.Cells(Rows.Count, "B").End(3).Row
        arr = sh.Range("A1:J" & i).Value
        j = 1
        For i = 2 To UBound(arr, 1)
            If arr(i, col) >= 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 = shL.Cells(Rows.Count, "A").End(3).Row + 2
        shL.Range("A" & i).Resize(j, UBound(arr, 2)) = arr
    End If
Next sh

shL.Select

End Sub

Function SayfaVar(shName As String) As Boolean
    On Error Resume Next
    SayfaVar = CBool(Len(Worksheets(shName).Name) > 0)
End Function