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.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 SubKod:Function SayfaVar(shName As String) As Boolean On Error Resume Next SayfaVar = CBool(Len(Worksheets(shName).Name) > 0) End Function
-
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 sqoist
- Başlangıç tarihi
denedim gayet hızlı da sonuç veriyor ama şablonu da kopyalamak istiyorum onun ile ilgileniyor.
makroyu kopyalayamadımayrıntılar sizde artık
- Katılım
- 4 Haziran 2005
- Mesajlar
- 15,485
- Excel Vers. ve Dili
- Ofis 365 Türkçe
kopyalarsınız, biraz bilgi yeterli
Valla yapamadım sizden ricam sayfalardaki renklendirmeye göre listeyi çektirmeniz yapabilirseniz çok makbule geçer
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
- Katılım
- 4 Haziran 2005
- Mesajlar
- 15,485
- Excel Vers. ve Dili
- Ofis 365 Türkçe
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.
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:
kardeşim ellerine sağlık şimdi deneme fırsatım oldu on numara olmuş