• DİKKAT

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

Verilen isme göre yeni çalışma sayfası oluşturma

R

rtk19641990

Katılım
20 Mart 2009
Mesajlar
333
Excel Vers. ve Dili
office 2003 ingilizce
Günaydın,
Bir ana datam var. Buradan çeşitli kriterlere göre veri ayıklayıp başka sayfalara aktarıyorum. Ama sayfaları önceden kendim insert worksheet şeklinde manuel oluşturuyorum. Kodda olduğu gibi:

Sub Internet_Aktar()
Dim sonsat As Long, sonsut As Integer, Sr As Worksheet, rsonsat As Long
Application.ScreenUpdating = False
On Error Resume Next

Sheets("Yurtdışı").Select
Set Sr = Sheets("İnternet")

rsonsat = Sr.Cells(Rows.Count, "BR").End(xlUp).Row + 1
sonsat = Cells(Rows.Count, "BR").End(xlUp).Row
sonsut = Cells(1, Columns.Count).End(xlToLeft).Column

[A1].AutoFilter Field:=4, Criteria1:="İNTERNET" '4.(D) sütununda INTERNET ölçütü aranır.
'[A1].AutoFilter Field:=38, Criteria1:="TR" '38.(AL) sütununda TR ölçütü aranır.

Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible). _
Copy Sr.Range("A" & rsonsat)

Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible). _
EntireRow.Delete
[A1].AutoFilter
Application.ScreenUpdating = True
MsgBox "İnternetler aktarıldı.", vbOKOnly + vbInformation, Application.UserName
End Sub

Yapmak istediğim İnternet sheetini yaratmadan bu kodun içinde kendi yaratıp kopyalasın.
Buradaki kodu da buradaki üstatlardan yardım alarak oluşturdum. Onu da belirtmek isterim.
İyi çalışmalar.
 
Son düzenleme:
Yardımcı olabilecek bir arkadaşım var mı acaba?
 
Son düzenleme:
İlgilenebilecek arkadaşım var mı acaba?
 
Son düzenleme:
Selamlar,

Örnek dosyanız olmadığı için deneme fırsatım olmadı. Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub Internet_Aktar()
    Dim sonsat As Long, sonsut As Integer, Sr As Worksheet, rsonsat As Long
    Application.ScreenUpdating = False
    
    On Error GoTo Ekle
    Sheets("İnternet").Select
    GoTo Devam
    
Ekle:
    Set Sr = Sheets.Add
    Sr.Name = "İnternet"
    On Error GoTo 0
Devam:
    Set Sr = Sheets("İnternet")
    Sheets("Yurtdışı").Select
    
    rsonsat = Sr.Cells(Rows.Count, "BR").End(xlUp).Row + 1
    sonsat = Cells(Rows.Count, "BR").End(xlUp).Row
    sonsut = Cells(1, Columns.Count).End(xlToLeft).Column
    
    [A1].AutoFilter Field:=4, Criteria1:="İNTERNET" '4.(D) sütununda INTERNET ölçütü aranır.
    '[A1].AutoFilter Field:=38, Criteria1:="TR" '38.(AL) sütununda TR ölçütü aranır.
    
    Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible). _
    Copy Sr.Range("A" & rsonsat)
    
    Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible). _
    EntireRow.Delete
    [A1].AutoFilter
    Application.ScreenUpdating = True
    MsgBox "İnternetler aktarıldı.", vbOKOnly + vbInformation, Application.UserName
End Sub
 
Çok teşekkür ederim. Bir ufak ricam daha olsa. Ana sayfada birinci satırsa başlık kısımları var. Onunla beraber kopyalamak için ne yapmam gerekiyor?
OTORİZASYON NO AMİR ŞUBE İŞLEM REF. İŞLEMİN KAYNAĞI İŞLEM TARİHİ gibi
 
Örnek dosya ekledir.
Saygılarımla
 

Ekli dosyalar

Son düzenleme:
Selamlar,

Aşağıdaki kodu denermisiniz.

Kod: 
Option Explicit
 
Sub Internet_Aktar()
    Dim sonsat As Long, sonsut As Integer, Sr As Worksheet, rsonsat As Long
    Application.ScreenUpdating = False
    
    On Error GoTo Ekle
    Sheets("İnternet").Select
    GoTo Devam
    
Ekle:
    Set Sr = Sheets.Add
    Sr.Name = "İnternet"
    On Error GoTo 0
Devam:
    Set Sr = Sheets("İnternet")
    Sheets("Yurtdışı").Select
    
    rsonsat = Sr.Cells(Rows.Count, "A").End(xlUp).Row
    If rsonsat > 1 Then rsonsat = rsonsat + 1
    sonsat = Cells(Rows.Count, "A").End(xlUp).Row
    sonsut = Cells(1, Columns.Count).End(xlToLeft).Column
    
    Range("A1").AutoFilter Field:=4, Criteria1:="İNTERNET"
    
    If rsonsat > 1 Then
        Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible).Copy Sr.Range("A" & rsonsat)
    Else
        Range("A1").CurrentRegion.Copy Sr.Range("A" & rsonsat)
    End If
    
    Range(Cells(2, 1), Cells(sonsat, sonsut)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    Range("A1").AutoFilter
    
    Application.ScreenUpdating = True
    
    MsgBox "İnternetler aktarıldı.", vbOKOnly + vbInformation, Application.UserName
End Sub
 
Günaydın,
Yardımlarınız sayesinde çok şey öğreniyorum. Bu aktarma işlemini birden fazla sayfa için yapmak istersem her biri için ayrı ayrı mı çalıştırmam gerekiyor? Bir seferde bütün sayfaları oluşturabilir miyim?
 
Selamlar,

Tabiki ayrı ayrı yapmanıza gerek yok. Fakat size verdiğimiz cevaplar sorularınıza göre şekilleniyor. Sorularınızda detaylı açıklamalar yapıp gerekiyorsa örnek dosya eklerseniz sonuca gitmek daha kolay olacaktır.
 
Korhan Bey,
Ekte küçük bir örnek hazırladım. Yurtdışı sayfasında D kolonunda:
İNTERNET olanlar İnternet Sayfasına,
O kolonunda:
TR olanlar Yurtiçi sayfasına,
BH ve THB BANK olanlar Bahreyn,
Yurtiçinden de TR ve THB Bank olanlar mahsup
adlı sayfalara aktarmak istiyorum.
yardımcı olduğunuz kod üzerinden çalışıyorum ancak

Range("A1").AutoFilter Field:=4, Criteria1:="İNTERNET satırında diğer sayfalara atması için kullanacağım kriterleri beceremedim. Yani aynı anda hepsini nasıl seçtireceğim?
 

Ekli dosyalar

Selamlar,

Aşağıdak kodu denermisiniz.

Kod: 
Option Explicit
 
Sub SAYFALARA_AKTAR()
    Dim SAYFA_ADI() As Variant, X As Byte
    Dim S1 As Worksheet, S2 As Worksheet, SAYFA As Worksheet
    Dim Satır As Long, Son_Satır As Long, Son_Sütun As Byte
    
    Set S1 = Sheets("Yurtdışı")
    
    Application.ScreenUpdating = False
    
    SAYFA_ADI = Array("İNTERNET", "YURTİÇİ", "BAHREYN", "MAHSUP")
    
    For X = 0 To UBound(SAYFA_ADI)
        If SAYFA_VARMI(SAYFA_ADI(X)) = False Then
            Sheets.Add
            ActiveSheet.Name = SAYFA_ADI(X)
        End If
    Next
    
    For Each SAYFA In ThisWorkbook.Worksheets
        Select Case SAYFA.Name
            Case Is = "İNTERNET"
                With SAYFA
                    Satır = .Cells(.Rows.Count, "A").End(xlUp).Row
                    If Satır > 1 Then Satır = Satır + 1
                    Son_Satır = S1.Cells(S1.Rows.Count, "A").End(xlUp).Row
                    Son_Sütun = S1.Cells(1, S1.Columns.Count).End(xlToLeft).Column
        
                    S1.Range("A1").AutoFilter Field:=4, Criteria1:="İNTERNET"
                
                    If Satır > 1 Then
                        On Error Resume Next
                        S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).Copy .Range("A" & Satır)
                        On Error GoTo 0
                    Else
                        S1.Range("A1").CurrentRegion.Copy .Range("A" & Satır)
                    End If
                    
                    On Error Resume Next
                    S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    S1.Range("A1").AutoFilter
                    .Cells.EntireColumn.AutoFit
                End With
            
            Case Is = "YURTİÇİ"
                With SAYFA
                    Satır = .Cells(.Rows.Count, "A").End(xlUp).Row
                    If Satır > 1 Then Satır = Satır + 1
                    Son_Satır = S1.Cells(S1.Rows.Count, "A").End(xlUp).Row
                    Son_Sütun = S1.Cells(1, S1.Columns.Count).End(xlToLeft).Column
        
                    S1.Range("A1").AutoFilter Field:=15, Criteria1:="TR"
                
                    If Satır > 1 Then
                        On Error Resume Next
                        S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).Copy .Range("A" & Satır)
                        On Error GoTo 0
                    Else
                        S1.Range("A1").CurrentRegion.Copy .Range("A" & Satır)
                    End If
                    
                    On Error Resume Next
                    S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    S1.Range("A1").AutoFilter
                    .Cells.EntireColumn.AutoFit
                End With
                
                Set S2 = Sheets("YURTİÇİ")
                With Sheets("MAHSUP")
                    Satır = .Cells(.Rows.Count, "A").End(xlUp).Row
                    If Satır > 1 Then Satır = Satır + 1
                    Son_Satır = S2.Cells(S2.Rows.Count, "A").End(xlUp).Row
                    Son_Sütun = S2.Cells(1, S2.Columns.Count).End(xlToLeft).Column
        
                    S2.Range("A1").AutoFilter Field:=15, Criteria1:="TR"
                    S2.Range("A1").AutoFilter Field:=16, Criteria1:="THB BANK"
                
                    If Satır > 1 Then
                        On Error Resume Next
                        S2.Range(S2.Cells(2, 1), S2.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).Copy .Range("A" & Satır)
                        On Error GoTo 0
                    Else
                        S2.Range("A1").CurrentRegion.Copy .Range("A" & Satır)
                    End If
                    
                    On Error Resume Next
                    S2.Range(S2.Cells(2, 1), S2.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    S2.Range("A1").AutoFilter
                    .Cells.EntireColumn.AutoFit
                End With
            
            Case Is = "BAHREYN"
                With SAYFA
                    Satır = .Cells(.Rows.Count, "A").End(xlUp).Row
                    If Satır > 1 Then Satır = Satır + 1
                    Son_Satır = S1.Cells(S1.Rows.Count, "A").End(xlUp).Row
                    Son_Sütun = S1.Cells(1, S1.Columns.Count).End(xlToLeft).Column
        
                    S1.Range("A1").AutoFilter Field:=15, Criteria1:="BH"
                    S1.Range("A1").AutoFilter Field:=16, Criteria1:="THB BANK"
                
                    If Satır > 1 Then
                        On Error Resume Next
                        S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).Copy .Range("A" & Satır)
                        On Error GoTo 0
                    Else
                        S1.Range("A1").CurrentRegion.Copy .Range("A" & Satır)
                    End If
                    
                    On Error Resume Next
                    S1.Range(S1.Cells(2, 1), S1.Cells(Son_Satır, Son_Sütun)).SpecialCells(xlCellTypeVisible).EntireRow.Delete
                    On Error GoTo 0
                    S1.Range("A1").AutoFilter
                    .Cells.EntireColumn.AutoFit
                End With
        End Select
    Next
            
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veriler ilgili sayfalara aktarılmıştır.", vbOKOnly + vbInformation, Application.UserName
End Sub
 
Function SAYFA_VARMI(SAYFAADI As Variant) As Boolean
    On Error Resume Next
    SAYFA_VARMI = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function
 
Sadece Yurtiçinden mahsup' a atamadım. Yurtiçinden de THB Bank olanlar mahsupa atılacaktı. Kriteri de:
S1.Range("A1").AutoFilter Field:=16, Criteria1:="THB BANK" olarak yazdım ama olmadı
 
Bir tek şu fark var
Case Is = "Yurtiçi"
With Sheets("Mahsup")

diğerlerinde Case Is = "Yurtiçi"
With SAYFA
 
Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.
 
Korhan Bey merhaba,
Yardımlarınız sayesinde bir defada verilen kritere göre diğer sayfalara verileri atıyorum. Ancak bir sayfaya bu iki kriteri sağlayan verileri aktarmam gerekiyor ama sadece istanbul olanı aktarıyor.
S2.Range("A1").AutoFilter Field:=38, Criteria1:="THB BANK /ANKARA"
S2.Range("A1").AutoFilter Field:=38, Criteria1:="THB BANK /İSTANBUL"

yardımınızı rica ederim. İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst