• DİKKAT

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

Aylık Fatura Dökümünü Sheet Sheet Ayrıştırma

E

erseljti

Katılım
20 Ocak 2012
Mesajlar
118
Excel Vers. ve Dili
Office 2016-Türkçe
Sevgili Üstadlar Merhaba.
Önemli bir çalışma hakkında ciddi ve acil yardıma ihtiyacım var.İlginiz için şimdiden teşekkürler..
İsteğim EK teki Dosyada
Data Sheetinde A sutununda yer alan tarihlerin
Tek bir buton koymak istiyorum bu butona tıkladığımızda;
01-09/05/2012 tarihleri kapsayan satırları 01-09 Sheetine (Bu Sheete sadece 01-09/05/2012 tarihleri atması diğer tüm tarihleri silmesi)
10-19/05/2012 tarihi kapsayan satırları 10-19 Sheetine (Bu Sheete sadece 10-19/05/2012 tarihleri atması diğer tüm tarihleri silmesi)
20-29/05/2012 tarihi kapsayan satırları 20-29 Sheetine (Bu Sheete sadece 20-29/05/2012 tarihleri atması diğer tüm tarihleri silmesi)
30-31/05/2012 tarihi kapsayan satırları 30-31 Sheetine (Bu Sheete sadece 30-31/05/2012 tarihleri atması diğer tüm tarihleri silmesi)

Ayrıca Tüm Sheetlerde D sutunundaki Matbu No larını küçükten büyüğe doğru sıralayarak atmasını istiyorum

Konuyla ilgili acil desteğe ihtiycaım var Lütfen desteğinizi esrgemeyin
 

Ekli dosyalar

Son düzenleme:
Kod: 
Sub tarih_fltr()
'
Application.ScreenUpdating = False
Dim trh As Range
sbasla = Timer
son = Sheets("Data").Cells(Rows.Count, "a").End(xlUp).Row
Set dizi = Sheets("Data").Range("a2" & ":a" & son)
 Worksheets("01-09").Activate
 silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
Sheets("01-09").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then

If trh >= Replace(Sheets("sorgu").Range("c6").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d6"), ".", "/") Then
x = x + 1
 trh.EntireRow.Copy Sheets("01-09").Range("a65536").End(3)(2, 1)
End If: End If
Next

' yeni
Worksheets("10-19").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("10-19").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c7").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d7"), ".", "/") Then
trh.EntireRow.Copy Sheets("10-19").Range("a65536").End(3)(2, 1)
End If: End If
Next
' yeni

Worksheets("20-29").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("20-29").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c8").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d8"), ".", "/") Then
trh.EntireRow.Copy Sheets("20-29").Range("a65536").End(3)(2, 1)
End If: End If
Next

' yeni
Worksheets("30-31").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("30-31").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c9").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d9"), ".", "/") Then
trh.EntireRow.Copy Sheets("30-31").Range("a65536").End(3)(2, 1)
End If: End If
Next
sbitis = Timer
Application.ScreenUpdating = True
sure = Format(sbitis - sbasla, "0.0") & "sn."
 MsgBox " A.Ş." & " İşlem süresi: " & sure, vbOKOnly, "snx111"
End Sub
 
Son düzenleme:
İlginiz için teşekkür ederim.
İşimi görecek ama bir eksiğim kaldı EK e Makroyu koydum
Sadece istediğim tarih aralığı Sorgu sheetinden alması bu mümkünmü
 

Ekli dosyalar

ilk mesajdaki kod güncellendi
 
Son düzenleme:
snx111' Alıntı:
süre ne gösteriyor ?
Genişletmek için tıkla ...
10,7 sn hocam
çok manyak bir şey olmuş.
Ellerinize sağlık
Hocam şimdi takıldığım bi husus kaldı.
01-09/10-19/20-29/30-31
Sheet lerinde K-L-M-N sutunlarına sabit formül koyacağım
Ama her makroyu çalıştırdığımda bu shhetlerdeki tüm veriler siliniyor.
Bunu yapmak mümkünmü
 
benim pc amd phenom 4 x 3,40 ghz 1 senelik pc 17 saniye . sizdeki donanım nedir ?

Sheets("01-09").Range("a2" & ":j" & son).ClearContents
kod a:j arası siliyor copyalamayı rows olarak yaptığım için üstüne yapıştırıyor. bi bakmam lazım :)
 
Son düzenleme:
snx111' Alıntı:
benim pc amd phenom 4 x 3,40 ghz 1 senelik pc 17 saniye . sizdeki donanım nedir ?

Sheets("01-09").Range("a2" & ":j" & son).ClearContents
a:j arası siliyor formüle dokunmuyor ????
Genişletmek için tıkla ...
Hocam formül öyle haklısınız.
Ama tablo üzerinde Sheetlerden K veya L sutununa herhangi bir değer yazıp makroyu çalıştırır mısınız.Siliyor o zaman çok ilginç

Hocam bendeki donanmı İntel İ7 2670
 
Hocam inceleyebildiniz mi
Bir tek bu sıkıntım kaldı yardımlarınızı esirgemeyin lütfen
 
Kod: 
Sub tarih_fltr()
'
Dim trh As Range
Application.ScreenUpdating = False
Application.Calculation = xlManual
sbasla = Timer
son = Sheets("Data").Cells(Rows.Count, "a").End(xlUp).Row
Set dizi = Sheets("Data").Range("a2" & ":a" & son)
 Worksheets("01-09").Activate
 silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
Sheets("01-09").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then

If trh >= Replace(Sheets("sorgu").Range("c6").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d6"), ".", "/") Then

 Sheets("Data").Range("a" & trh.Row & ":j" & trh.Row).Copy _
 Sheets("01-09").Range("a65536").End(3)(2, 1)
End If: End If
Next

' yeni
Worksheets("10-19").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("10-19").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c7").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d7"), ".", "/") Then
Sheets("Data").Range("a" & trh.Row & ":j" & trh.Row).Copy _
Sheets("10-19").Range("a65536").End(3)(2, 1)
End If: End If
Next
' yeni

Worksheets("20-29").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("20-29").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c8").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d8"), ".", "/") Then
Sheets("Data").Range("a" & trh.Row & ":j" & trh.Row).Copy _
Sheets("20-29").Range("a65536").End(3)(2, 1)
End If: End If
Next

' yeni
Worksheets("30-31").Activate
silson = ActiveSheet.Cells(Rows.Count, "a").End(xlUp).Row
 Sheets("30-31").Range("a2" & ":j" & son).ClearContents
For Each trh In dizi
If Not trh Is Nothing Then
If trh >= Replace(Sheets("sorgu").Range("c9").Value, ".", "/") And _
trh <= Replace(Sheets("sorgu").Range("d9"), ".", "/") Then
Sheets("Data").Range("a" & trh.Row & ":j" & trh.Row).Copy _
Sheets("30-31").Range("a65536").End(3)(2, 1)
End If: End If
Next
sbitis = Timer

sure = Format(sbitis - sbasla, "0.0") & "sn."
beep:  MsgBox " A.Ş." & " İşlem süresi: " & sure, vbOKOnly, "snx111"
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
Sheets("Data").Select
End Sub

Sıralama işlemi için data sayfasını makro öncesi sıralamalısınız bu makroda d stunu sıralama kodları yok.

Yeni süreyi alabilirmiyim ?
 
Son düzenleme:
peki makro ile sıralayabilme şansımız varmı
(Biliyorum çok oldum ama)
 
sıralama yandaki formüllerinizin yanlış çalışmasına sebep olabilir.. Sisteminize uygun olanı bulun. makroya eklemek için her 'yeni yazan satırların üstüne kopyalayın.

tüm sayfa
Kod: 
Columns("A:ıv").Select
    Selection.Sort Key1:=Range("d2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("a1").Select

a:j arası
Kod: 
Columns("A:j").Select
    Selection.Sort Key1:=Range("d2"), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
Range("a1").Select

bu arada ... HALEN son SÜREYİ VERMEDİNİZ
 
Son düzenleme:
9.6 Sn oldu hocam şu an
Sıralama formülün girince 12 sn
 
İyi hayırlı olsun ozaman :)
bendede 13 saniye ilerde yeni pc toplarsam intel alayım ozaman .
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst