• DİKKAT

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

çalışma kitabın sayfalarından veri çekme

  • Konbuyu başlatan Konbuyu başlatan muhsar
  • Başlangıç tarihi Başlangıç tarihi
M

muhsar

Altın Üye
Katılım
16 Mart 2019
Mesajlar
281
Excel Vers. ve Dili
2010 tütkçe
merhaba,
ekteki çalışmamda tüm sahiferin A sütununda dosya no var,M sütununda ise klasör no.arada diğer veriler var,(ihtiyaç olursa ben buradaki örneğe bakarak uyarlayabilirim)
.benim yapmak istediğim liste sayfasında getir modülüne tıkladığımda AKTİF isimli sayfa hariç diğer tüm sayfaların A sütunundaki dosya nolarını M sütunundaki klasör nolarını E sütununa sayfa adlarının yazarak alt alta sıralamasıdır.

ilgilenen arkadaşa şimdiden teşekkür ederim
 

Ekli dosyalar

Merhaba.

Aşağıdaki kodu deneyin.

Kod: 
Sub getir()
    Dim syf As Worksheet
    Dim SatirSay As Integer
    Dim Bak As Integer
    Dim Say As Integer
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = ActiveSheet.Name Then
            SatirSay = syf.Cells(Rows.Count, "A").End(xlUp).Row
            For Bak = 2 To SatirSay
                If Not syf.Cells(Bak, "M") = "" Then
                    Say = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cells(Say, "A") = syf.Cells(Bak, "A")
                    Cells(Say, "B") = syf.Cells(Bak, "M")
                    Cells(Say, "C") = syf.Name
                End If
            Next
        End If
    Next
End Sub
 
Merhaba
Kodları kendinize uyarlayıp dener misiniz
Kod: 
 Sub numan()
Dim sht As Worksheet
Dim x As Long
Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
    For Each sht In Worksheets
        If sht.Name <> "LİSTE" Then
          For x = 2 To sht.Range("A" & Rows.Count).End(3).Row
    Range("A65536").End(xlUp).Offset(1, 0) = sht.Range("A" & x).Value
   Range("A65536").End(xlUp).Offset(0, 1) = sht.Range("M" & x).Value
   Range("A65536").End(xlUp).Offset(0, 2) = sht.Name
Next x
End If
    Next
    Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlandı", , "Numan Şamil"
End Sub
 
Muzaffer Ali' Alıntı:
Merhaba.

Aşağıdaki kodu deneyin.

Kod: 
Sub getir()
    Dim syf As Worksheet
    Dim SatirSay As Integer
    Dim Bak As Integer
    Dim Say As Integer
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = ActiveSheet.Name Then
            SatirSay = syf.Cells(Rows.Count, "A").End(xlUp).Row
            For Bak = 2 To SatirSay
                If Not syf.Cells(Bak, "M") = "" Then
                    Say = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cells(Say, "A") = syf.Cells(Bak, "A")
                    Cells(Say, "B") = syf.Cells(Bak, "M")
                    Cells(Say, "C") = syf.Name
                End If
            Next
        End If
    Next
End Sub
Genişletmek için tıkla ...
merhaba;kodlar çalıştı fakat AKTİF isimli sayfa hariç diğer sayfaları getirmesi gerektiğini gözden kaçrmısınız.bu kısmı ilave edebilirmisiniz rica etsem
son olarak makro çalıştığı zaman liste sayfasındaki verileri önce temizleyip sonra verileri getirmesi gerekmektedir.
 
Sub numan()
Dim sht As Worksheet
Dim x As Long
Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
For Each sht In Worksheets
If sht.Name <> "LİSTE" Then
For x = 2 To sht.Range("A" & Rows.Count).End(3).Row
Range("A65536").End(xlUp).Offset(1, 0) = sht.Range("A" & x).Value
Range("A65536").End(xlUp).Offset(0, 1) = sht.Range("M" & x).Value
Range("A65536").End(xlUp).Offset(0, 2) = sht.Name
Next x
End If
Next
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlandı", , "Numan Şamil"
End Sub
yukardaki kodda ;

merhaba,AKTİF isimli sayfa hariç diğerlerinden veri çekmesi gerekiyor,ayrıca eğer a sütununda dosya no karşısında M sütununda klasör no yazılı olanları getirmesi gerekiyor.
 
Üsradlarım yapamadım yardımcı olmanız mümkünmü ekte dosya gönderdim
 

Ekli dosyalar

muhsar' Alıntı:
merhaba;kodlar çalıştı fakat AKTİF isimli sayfa hariç diğer sayfaları getirmesi gerektiğini gözden kaçrmısınız.bu kısmı ilave edebilirmisiniz rica etsem
son olarak makro çalıştığı zaman liste sayfasındaki verileri önce temizleyip sonra verileri getirmesi gerekmektedir.
Genişletmek için tıkla ...

Kodlar zaten aktif sayfa hariç olacak şekilde yazıldı. Diğer dediğinizi ekledim.

Kod: 
Sub getir()
    Dim syf As Worksheet
    Dim SatirSay As Integer
    Dim Bak As Integer
    Dim Say As Integer
    Range("A2:C" & Rows.Count).ClearContents
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = ActiveSheet.Name Then
            SatirSay = syf.Cells(Rows.Count, "A").End(xlUp).Row
            For Bak = 2 To SatirSay
                If Not syf.Cells(Bak, "M") = "" Then
                    Say = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cells(Say, "A") = syf.Cells(Bak, "A")
                    Cells(Say, "B") = syf.Cells(Bak, "M")
                    Cells(Say, "C") = syf.Name
                End If
            Next
        End If
    Next
End Sub
 
Muzaffer Ali' Alıntı:
Kodlar zaten aktif sayfa hariç olacak şekilde yazıldı. Diğer dediğinizi ekledim.

Kod: 
Sub getir()
    Dim syf As Worksheet
    Dim SatirSay As Integer
    Dim Bak As Integer
    Dim Say As Integer
    Range("A2:C" & Rows.Count).ClearContents
    For Each syf In ThisWorkbook.Worksheets
        If Not syf.Name = ActiveSheet.Name Then
            SatirSay = syf.Cells(Rows.Count, "A").End(xlUp).Row
            For Bak = 2 To SatirSay
                If Not syf.Cells(Bak, "M") = "" Then
                    Say = Cells(Rows.Count, "A").End(xlUp).Row + 1
                    Cells(Say, "A") = syf.Cells(Bak, "A")
                    Cells(Say, "B") = syf.Cells(Bak, "M")
                    Cells(Say, "C") = syf.Name
                End If
            Next
        End If
    Next
End Sub
Genişletmek için tıkla ...
ilginiz için teşekkür ederim ,ben anlatamadım size sanırım.aktif sayfa derken AKTİF isimli bir sayfa var,bu sayfa hariç demek istediğim.
 
Merhaba
Sadece "AKTİF " sayfada hariç ise

Kod: 
 Sub numan()
Dim sht As Worksheet
Dim x As Long
Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
    For Each sht In Worksheets
        If sht.Name <> "AKTİF" Then
          For x = 2 To sht.Range("A" & Rows.Count).End(3).Row
           If sht.Range("M" & x).Value <> "" Then
    Range("A65536").End(xlUp).Offset(1, 0) = sht.Range("A" & x).Value
   Range("A65536").End(xlUp).Offset(0, 1) = sht.Range("M" & x).Value
   Range("A65536").End(xlUp).Offset(0, 2) = sht.Name
   End If
Next x
End If
    Next
    Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlandı", , "Numan Şamil"
End Sub
 
Hem "AKTİF" sayfa hem de "LİSTE" hariç ise
Kod: 
Sub numan()
Dim sht As Worksheet
Dim x As Long
Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
    For Each sht In Worksheets
        If sht.Name <> "AKTİF" And sht.Name <> "LİSTE" Then
          For x = 2 To sht.Range("A" & Rows.Count).End(3).Row
           If sht.Range("M" & x).Value <> "" Then
    Range("A65536").End(xlUp).Offset(1, 0) = sht.Range("A" & x).Value
   Range("A65536").End(xlUp).Offset(0, 1) = sht.Range("M" & x).Value
   Range("A65536").End(xlUp).Offset(0, 2) = sht.Name
   End If
Next x
End If
    Next
    Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlandı", , "Numan Şamil"
End Sub
 
numan şamil' Alıntı:
Hem "AKTİF" sayfa hem de "LİSTE" hariç ise
Kod: 
Sub numan()
Dim sht As Worksheet
Dim x As Long
Range("A2:C" & Rows.Count).ClearContents
Application.ScreenUpdating = False
    For Each sht In Worksheets
        If sht.Name <> "AKTİF" And sht.Name <> "LİSTE" Then
          For x = 2 To sht.Range("A" & Rows.Count).End(3).Row
           If sht.Range("M" & x).Value <> "" Then
    Range("A65536").End(xlUp).Offset(1, 0) = sht.Range("A" & x).Value
   Range("A65536").End(xlUp).Offset(0, 1) = sht.Range("M" & x).Value
   Range("A65536").End(xlUp).Offset(0, 2) = sht.Name
   End If
Next x
End If
    Next
    Application.ScreenUpdating = True
        MsgBox "İşleminiz tamamlandı", , "Numan Şamil"
End Sub
Genişletmek için tıkla ...
çok teşekkür ederim.elinize sağlık
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst