Makro İle Çoklu Satır Taşıma
Tarih
20/08/2013 00:14
Konu Sahibi
boraday
Yorumlar
9
Okunma
2559
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ı: 37)
boraday, 07-04-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla

benremix
Uzman
Kullanici Avatari
Uzman
R.... S....
4.433
17/05/2009
365
Ankara
Ofis 2010
Dün,18:55
Çözüldü 
Sponsor Reklam
Ö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
16/03/2017,17:22
Çö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
16/03/2017,17:22
Çözüldü 
Sponsor Reklam
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

turankr
Üye
Kullanici Avatari
Üye
11
1
05/01/2017
0
-
-
13/02/2017,16:37
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [G:G]) Is Nothing Then GoTo 10
On Error GoTo son
ActiveSheet.Unprotect
Cells.Locked = False
If Target.Value = "MASRAF" Then
Range("I:I").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ÇIKAN" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "SATIŞ" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALC DEKONT" Then
Range("I:I,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "GİREN" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "ALIŞ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "BRÇ DEKONT" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
End If
If Target.Value = "KASA DEVRİ" Then
Range("J:J,H:H").Locked = True
ActiveSheet.Protect
son:
End If
10:
If Intersect(Target, [F:F]) Is Nothing Then GoTo 20
If Target <> "" And Target = Cells(Target.Row, "M") Then
    Cells(Target.Row, "G") = "ÇIKAN"
End If
20:
If Intersect(Target, [M:M]) Is Nothing Then GoTo 30
If Target <> "" And Target = Cells(Target.Row, "F") Then
    Cells(Target.Row, "G") = "ÇIKAN"
End If
30:
For i = 1 To Sheets("KASA").Range("F5000").End(3).Row
If (Cells(i, "F") = "") Then GoTo atla
s = s + 1
For t = 1 To 13
If (Cells(t, "A") = "") Then GoTo atla
Sheets("RAPOR_2").Cells(s, t).Value = Sheets("KASA").Cells(i, t).Value
Next t
atla:
Next i
End Sub

Yukardaki makroyu, excel'i kasmadan çalışacak hale getirebilirmiyiz?
Cevapla

turankr
Üye
Kullanici Avatari
Üye
11
1
05/01/2017
0
-
-
13/02/2017,16:37
Sponsor Reklam
Örnek dosya ve ne istediğim bu adreste. İlgilenirseniz çok sevinirim.

http://s3.dosya.tc/server10/i7wpwl/n_sek...7.rar.html
Cevapla


Konuyu Okuyanlar: 1 Ziyaretçi


Konu ile Alakalı Benzer Konular
Konular Yazar Yorumlar Okunma Tarih Son Yorum
  Satır Uzunluğuna Bağlı Olarak Hizalama mmert06 14 790 01/04/2017, 14:34 atoz112
  Satır Sil Ekle Değiştir m_demir 4 143 28/03/2017, 11:56 atoz112
  Excel'de Makro Ya Da Modülde Düzenleme Yapma mehami 2 130 24/02/2017, 10:57 mehami
  Kullanılmayan Satır-Sütun Gizleme ozkovlu29 6 187 21/02/2017, 11:39 atoz112
  Çoklu Süzme Arama alanında Hata kenevir47 8 426 09/12/2016, 16:18 kenevir47


Türkçe Çeviri: MCTR, Yazılım: MyBB, © 2002-2017 MyBB Group.
DMCA.com Protection Status