Konu Araçları | Seçenekler: | Gösterim Stili
Tarih
20/08/2013 00:14
Konu Sahibi
boraday
Yorumlar
9
Okunma
3168
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ı: 38)
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
Bugün,20:34
Çö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
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ü 
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
Ö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
Çözüldü Satır Uzunluğuna Bağlı Olarak Hizalama mmert06 14 1.522 01/04/2017, 14:34 atoz112
Çözüldü Satır Sil Ekle Değiştir m_demir 4 411 28/03/2017, 11:56 atoz112
Çözüldü Excel'de Makro Ya Da Modülde Düzenleme Yapma mehami 2 365 24/02/2017, 10:57 mehami
Çözüldü Kullanılmayan Satır-Sütun Gizleme ozkovlu29 6 673 21/02/2017, 11:39 atoz112
Çözüldü Çoklu Süzme Arama alanında Hata kenevir47 8 718 09/12/2016, 16:18 kenevir47

Türkçe Çeviri: MCTR, Yazılım: MyBB, © 2002-2017 MyBB Group.
Forum use Krzysztof "Supryk" Supryczynski addons.