Makro İle Çoklu Satır Taşıma
Tarih
20/08/2013 00:14
Konu Sahibi
boraday
Yorumlar
3
Okunma
2053
Konuyu Oyla:
  • Derecelendirme: 0/5 - 0 oy
  • 5
  • 4
  • 3
  • 2
  • 1

Derecelendirme: 0/5 - 0 oy



boraday
Üye
Kullanici Avatari
Üye
31
8
07/04/2009
0
Tekirdağ
Ofis 2007
02/08/2016,10:58
Çözüldü 
Merhabalar,

Girilen tarihe göre (Özet Tablo!A2 ) diğer çalışma sayfasından ( Data ) aynı tarihi içeren satırları Özet tablo sayfasına aldırmak istiyorum. Alınacak sütunlar ( B-C-D-E-F-G-H-I-J-K-L ) sütunlarıdır. diğer sütunların taşınmasına gerek yoktur. Bu taşıma işlemini makro veya başka formüller yazarak almak istiyorum. Yardımcı olacak arkadaşlara şimdiden teşekkür ederim..


Ek Dosyalar
.7z   SARIM ÜRETİM TAKİP AĞUSTOS-2013.7z (Dosya Boyutu: 379,81 KB / İndirme Sayısı: 36)
boraday, 07-04-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla


benremix
Uzman
Kullanici Avatari
Uzman
R.... S....
4.432
17/05/2009
365
Ankara
Ofis 2010
Dün,21:16
Çözüldü 
Örneğinizi inceleme fırsatım olmadı. Ancak macro kaydet yöntemiyle yapmayı denediniz mi?

Saygılar...
Bilgi paylaşıldıkça çoğalır....
Her engel, yaşam koşullarınızı daha iyileştirecek bir fırsattır.


Access için her zaman lazım olacak konu başlıkları listesi 


Cevapla


DUAYEN
Aktif Üye
Kullanici Avatari
Aktif Üye
S.... A....
1.026
13/08/2010
279
Yozgat
Ofis 2007
28/10/2016,11:41
Çözüldü 
Sorunuz tam anlaşılmıyor ney nereye taşınacak anlamadım.
Bizim için zor diye bir şey yoktur, imkansızsa zaman alır...
Cevapla


DUAYEN
Aktif Üye
Kullanici Avatari
Aktif Üye
S.... A....
1.026
13/08/2010
279
Yozgat
Ofis 2007
28/10/2016,11:41
Çözüldü 
Yinede şöyle bir örnek verebilim kendinize göre uyarlayınız.
Aşağıdaki kodu boş bir modüle uygulayıp deneyiniz.

Kod çalışırken ilk olarak size daha önce aktarım yaptığınız sayfaları silmek istiyormusunuz diye soracak evet derseniz önceki aktarım yapılan sayfalar silinecek. Hayır derseniz varolan sayfaların alt satırlarına devam ederek aktarım yapacaktır.

Kod:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
Option Explicit
 
Sub AKTAR()
    Dim S1, S2, S3, Sayfa, X, Satir
 
    If MsgBox("Daha önce aktardığınız sayfaları silmek istiyor musunuz?", vbCritical + vbYesNo) = vbNo Then GoTo 10
 
    Application.DisplayAlerts = False
 
    For Each Sayfa In ThisWorkbook.Worksheets
        If Sayfa.Name <> "Data" Then Sayfa.Delete
    Next
 
    Application.DisplayAlerts = True
 
10  Application.ScreenUpdating = False
 
    Set S1 = Sheets("Data")
 
    S1.Range("F1:F" & Rows.Count).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=S1.Cells(1, Columns.Count), Unique:=True
 
    For X = 2 To S1.Cells(Rows.Count, Columns.Count).End(3).Row
        S1.Range("A1").AutoFilter Field:=6, Criteria1:=S1.Cells(X, Columns.Count)
 
        If Sayfa_Kontrol(S1.Cells(X, Columns.Count)) Then
            Set S2 = Sheets(S1.Cells(X, Columns.Count).Text)
            Satir = S2.Cells(Rows.Count, 1).End(3).Row + 1
            If S1.Cells(Rows.Count, 1).End(3).Row > 1 Then
                S1.Range("A2:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 1)
                S1.Range("Y2:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 7)
                S1.Range("BE2:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 8)
                S1.Range("BH2:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 10)
                S1.Range("BL2:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S2.Cells(Satir, 11)
                S2.Range("A2:K" & Rows.Count).Sort Key1:=S2.Range("I2"), Order1:=xlAscending
            End If
 
        Else
 
            Set S3 = Sheets.Add
            S3.Move After:=Worksheets(Worksheets.Count)
            S3.Name = S1.Cells(X, Columns.Count)
 
            S1.Range("A1:F" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 1)
            S1.Range("Y1:Y" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 7)
            S1.Range("BE1:BF" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 8)
            S1.Range("BH1:BH" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 10)
            S1.Range("BL1:BL" & S1.Cells(Rows.Count, 1).End(3).Row).Copy S3.Cells(1, 11)
            S3.Range("A2:K" & Rows.Count).Sort Key1:=S3.Range("I2"), Order1:=xlAscending
        End If
    Next
 
    S1.Select
    S1.Cells(1, Columns.Count).EntireColumn.Delete
    S1.Range("A1").AutoFilter Field:=6
 
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
 
Function Sayfa_Kontrol(Sayfa_Adi As String) As Boolean
    On Error Resume Next
    Sayfa_Kontrol = CBool(Len(Worksheets(Sayfa_Adi).Name > 0))
End Function

Bizim için zor diye bir şey yoktur, imkansızsa zaman alır...
Cevapla







Konuyu Okuyanlar: 1 Ziyaretçi


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Tarih Son Yorum
  Çoklu Süzme Arama alanında Hata kenevir47 8 148 09/12/2016, 16:18 kenevir47
  Excel Filtreleme sonucu çıkan satır sayısı Ahmet Karaman 6 366 12/09/2016, 11:00 atoz112
  makro ile excele veri almak siyahhayis 4 778 05/06/2016, 15:48 atoz112
  sütundan çoklu veri arama ve hücreye yazdırma tolgahat 5 400 30/05/2016, 14:50 atoz112
  makro vba devre dışı hatası fehmikonkur 5 577 16/05/2016, 17:03 atoz112


Türkçe Çeviri: MCTR, Forum Yazılımı: MyBB, © 2002-2016 MyBB Group.
DMCA.com Protection Status
© Desing by XSTYLED| Develops by ozanakkaya