• 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

Selamlar,

Eğer aynı anda iki ölçütü filtreleyip aktarmak istiyorsanız aşağıdaki şekilde kullanabilirsiniz.

Kod: 
S2.Range("A1").AutoFilter Field:=38, Criteria1:="THB BANK /ANKARA", [COLOR=red][B]Operator:=xlOr[/B][/COLOR], Criteria2:="THB BANK /İSTANBUL"
 
Selamlar,

Üstteki mesajımdaki kodu güncelledim. İncelermisiniz.
 
Aynı hatayı alıyorum. Öncesinde başka bir sayfa için 38.ci alanı başka bir kriter için kullanıyorum. Ondan olabilir mi?
 
Bu hatayı veriyor ve sadece daha önce 38.ci alanda verilen kritere göre sayfayı oluşturuyor. Diğer sayfalar boş.
 
Örnek dosya ekledim.
D kolonu İNTERNET olanlar İnternet sayfasına
O kolonununda TR olanlar Yurtiçi sayfasına,
P kolonunda THB BANK olanlar Bahreyn sayfasına
Yurtiçi sayfasından THB BANK olanlar (Hem Ankara hem İstanbul) Mahsup sayfasına
Yapmak istdiğim bu. verdiğim zahmet için özür dilerim.
 

Ekli dosyalar

Selamlar,

Daha önce #12 nolu mesajınızda aşağıdaki kriteri belirtmiştiniz.

Yurtiçinden de TR ve THB Bank olanlar mahsup
adlı sayfalara aktarmak istiyorum.
Genişletmek için tıkla ...

Son mesajınızda ise aşağıdaki kriteri belirtmişsiniz.

Yurtiçi sayfasından THB BANK olanlar (Hem Ankara hem İstanbul) Mahsup sayfasına
Genişletmek için tıkla ...

Bu iki isteğiniz aynı kod içindemi yapılacak? Yoksa bir önceki isteğiniz iptalmi oldu?

Ayrıca dosyanızda;

38. alan yok?
"THB BANK /ANKARA" verisi yok?
"THB BANK /İSTANBUL" verisi yok?

Sanıyorum 38. alandan kastınız "P" sütunudur.
 
evet evet örneği sadeleştirdim. P sütünu.
Öncesinde sadece THB Bank idi şimdi iki office olduğu için mecburen bu kriterleri sağlayanları aktaracağım. TR ler yurtiçine, Yurtiçinden THB BANK olanlar(istanbul-ankara) mahsuba.
 
Selamlar,

Aşağıdaki 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:=16, Criteria1:="THB BANK ANKARA OFFICE", Operator:=xlOr, Criteria2:="THB BANK İSTANBUL OFFICE"
                
                    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
 
Çok çok teşekkür ederim. Verdiğiniz örnekte denedim. Herşey tamam görünüyor.
Tekrar teşekkürler
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst