• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

  • Konbuyu başlatan Konbuyu başlatan sqoist
  • Başlangıç tarihi Başlangıç tarihi
Necdet' Alıntı:
Her ne kadar bizim kodlarla ilgilenilmese de, ben yine de kodları ekleyim. :)

DOSYA

Kod: 
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

Kod: 
Function SayfaVar(shName As String) As Boolean
    On Error Resume Next
    SayfaVar = CBool(Len(Worksheets(shName).Name) > 0)
End Function
Genişletmek için tıkla ...
estafurullah olur mu öyle şey sizin eklediğiniz her kodu denedim , diğer arkadasın eklediği kod üzerinden ben başka makro da yaptığım için onun üzeriden devam ettim yaptılarınız değerli işlerimlerimizi hızlandırıyor ve kolaylaştırıyorsunuz.
 
Kodları denediniz mi? sonuç?
 
ayrıntılar sizde artık :)
 
Sayfadaki renklere göre mi listelenecek?
O zaman benim yöntemim geçerliliğini yitirir. Çünkü ben range ile değil dizi ile kod ürettim.
Böyle bir şeye neden gerek görüyorsunuz ki?
 
Necdet' Alıntı:
Sayfadaki renklere göre mi listelenecek?
O zaman benim yöntemim geçerliliğini yitirir. Çünkü ben range ile değil dizi ile kod ürettim.
Böyle bir şeye neden gerek görüyorsunuz ki?
Genişletmek için tıkla ...
sayfadaki renklendirmeye göre değil oradaki 50 adetin üstündeki malzememin rengi atıyorum kırmızı ise listele sayfasınada aynı renk kodu ile gelsin istiyorum aynı biçimlendirme ile yani
 
BENDe ondan söz ediyorum zaten. Benim kodlar onu yapmaz. klasik şekilde oku ve kopyala yapıştır demek gerek o da önceki arkadaşımın yaptığı yöntem ile olası.
 
Merhaba,
Kodların çalışması biraz uzun ama bir deneyin .

ÖZET sayfasındaki Maliyet ve Miktar butonlarının ikisini de aşağıdaki makroya bağlayın.
Sayfalarda gizli sütunların olmaması gerekir. Onları kontrol etmedim.

Kod: 
Public Sub Listele()

Dim col As Integer
Dim ShL As Worksheet
Dim i   As Long
Dim j   As Long
Dim k   As Long

Dim Sh  As Worksheet
Dim gen(1 To 10) As Double

gen(1) = 19.67: gen(2) = 31.11: gen(3) = 7.33: gen(4) = 14.56
gen(5) = 8.33: gen(6) = 50.11: gen(7) = 9.89: gen(8) = 6.67
gen(9) = 5.33: gen(10) = 14.89

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

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

Set ShL = Sheets("LİSTE")
ShL.Select
ActiveWindow.DisplayGridlines = False

For i = LBound(gen) To UBound(gen)
    ShL.Cells(1, i).ColumnWidth = gen(i)
Next i

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.Bold = True
    .Font.ColorIndex = 3
End With

j = 1

For Each Sh In Worksheets
    If IsNumeric(Sh.Name) Then
        j = j + 1
        k = j
        For i = 1 To Sh.Cells(Rows.Count, "B").End(3).Row
            If i = 1 Or Sh.Cells(i, col) >= 50 Then
                j = j + 1
                Sh.Range("A" & i & ":J" & i).Copy ShL.Cells(j, "A")
            End If
        Next i
        k = k + 1
        Cizgi Range("A" & k).CurrentRegion
    End If
Next Sh

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

MsgBox "İşlem Tamamdır....", vbInformation, "www.excel.web.tr"

End Sub

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

Sub Cizgi(rng As Range)

    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
    
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
    
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
    
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
    
    With rng.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThin
    End With
    
    With rng.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.499984740745262
        .Weight = xlThin
    End With
    
    With rng.Rows(1).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.499984740745262
        .Weight = xlMedium
    End With
    
    With rng.Rows(1).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
    
    rng.Rows(1).Font.Bold = True

End Sub
 
Son düzenleme:
Necdet' Alıntı:
Merhaba,
Kodların çalışması biraz uzun ama bir deneyin .

ÖZET sayfasındaki Maliyet ve Miktar butonlarının ikisini de aşağıdaki makroya bağlayın.
Sayfalarda gizli sütunların olmaması gerekir. Onları kontrol etmedim.

Kod: 
Public Sub Listele()

Dim col As Integer
Dim ShL As Worksheet
Dim i   As Long
Dim j   As Long
Dim k   As Long

Dim Sh  As Worksheet
Dim gen(1 To 10) As Double

gen(1) = 19.67: gen(2) = 31.11: gen(3) = 7.33: gen(4) = 14.56
gen(5) = 8.33: gen(6) = 50.11: gen(7) = 9.89: gen(8) = 6.67
gen(9) = 5.33: gen(10) = 14.89

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

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

Set ShL = Sheets("LİSTE")
ShL.Select
ActiveWindow.DisplayGridlines = False

For i = LBound(gen) To UBound(gen)
    ShL.Cells(1, i).ColumnWidth = gen(i)
Next i

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.Bold = True
    .Font.ColorIndex = 3
End With

j = 1

For Each Sh In Worksheets
    If IsNumeric(Sh.Name) Then
        j = j + 1
        k = j
        For i = 1 To Sh.Cells(Rows.Count, "B").End(3).Row
            If i = 1 Or Sh.Cells(i, col) >= 50 Then
                j = j + 1
                Sh.Range("A" & i & ":J" & i).Copy ShL.Cells(j, "A")
            End If
        Next i
        k = k + 1
        Cizgi Range("A" & k).CurrentRegion
    End If
Next Sh

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .DisplayAlerts = False
End With

MsgBox "İşlem Tamamdır....", vbInformation, "www.excel.web.tr"

End Sub

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

Sub Cizgi(rng As Range)

    With rng.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
   
    With rng.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
   
    With rng.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
   
    With rng.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThick
    End With
   
    With rng.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.4999
        .Weight = xlThin
    End With
   
    With rng.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.499984740745262
        .Weight = xlThin
    End With
   
    With rng.Rows(1).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ThemeColor = 1
        .TintAndShade = -0.499984740745262
        .Weight = xlMedium
    End With
   
    With rng.Rows(1).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = 0
        .PatternTintAndShade = 0
    End With
   
    rng.Rows(1).Font.Bold = True

End Sub
Genişletmek için tıkla ...
kardeşim ellerine sağlık şimdi deneme fırsatım oldu on numara olmuş
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst