• DİKKAT

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

Soru Veri Aktarma

  • Konbuyu başlatan Konbuyu başlatan Szg15
  • Başlangıç tarihi Başlangıç tarihi
S

Szg15

Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasında 4 adet buton var.
"A Şefliği Aktar" butonuna tıklayınca, A Şefliği çalışma kitabındaki F, G, H ve I sütunlarının 3.satırından itibaren 12.satıra kadar,
"1.Kısım Aktar" butonuna tıklayınca, 1.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 13.satırından itibaren 27.satıra kadar,
"2.Kısım Aktar" butonuna tıklayınca, 2.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 28.satırından itibaren 42.satıra kadar,
"3.Kısım Aktar" butonuna tıklayınca, 3.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 43.satırından itibaren 57.satıra kadar,

MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasının F, G, H ve I sütunlarının 3.satırlarından itibaren aşağıya doğru (A Şefliği için 3-12.satırlar, 1.Kısım için 13-27.satırlar, 2.Kısım için 28-42.satırlar, 3.Kısım için 43-57.satırlar) aktarmasını istiyorum. MÜDÜRLÜK isimli çalışma kitabı açık, diğerleri kapalı olacak. 5 çalışma kitabı da Lokal Bilgisayalarına ortak alandaki klasöründe duruyor. Çalışma kitapları Ek'te sunulmuştur. Yapılabilir mi böyle bir şey?
 
Szg15' Alıntı:
MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasında 4 adet buton var.
"A Şefliği Aktar" butonuna tıklayınca, A Şefliği çalışma kitabındaki F, G, H ve I sütunlarının 3.satırından itibaren 12.satıra kadar,
"1.Kısım Aktar" butonuna tıklayınca, 1.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 13.satırından itibaren 27.satıra kadar,
"2.Kısım Aktar" butonuna tıklayınca, 2.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 28.satırından itibaren 42.satıra kadar,
"3.Kısım Aktar" butonuna tıklayınca, 3.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 43.satırından itibaren 57.satıra kadar,

MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasının F, G, H ve I sütunlarının 3.satırlarından itibaren aşağıya doğru (A Şefliği için 3-12.satırlar, 1.Kısım için 13-27.satırlar, 2.Kısım için 28-42.satırlar, 3.Kısım için 43-57.satırlar) aktarmasını istiyorum. MÜDÜRLÜK isimli çalışma kitabı açık, diğerleri kapalı olacak. 5 çalışma kitabı da Lokal Bilgisayalarına ortak alandaki klasöründe duruyor. Çalışma kitapları Ek'te sunulmuştur. Yapılabilir mi böyle bir şey?
Genişletmek için tıkla ...
Altın üyelik onayımı bekliyorum, bu yüzden dosyaları ekleyemedim, en kısa sürede ekleyeceğim.
 
Szg15' Alıntı:
MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasında 4 adet buton var.
"A Şefliği Aktar" butonuna tıklayınca, A Şefliği çalışma kitabındaki F, G, H ve I sütunlarının 3.satırından itibaren 12.satıra kadar,
"1.Kısım Aktar" butonuna tıklayınca, 1.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 13.satırından itibaren 27.satıra kadar,
"2.Kısım Aktar" butonuna tıklayınca, 2.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 28.satırından itibaren 42.satıra kadar,
"3.Kısım Aktar" butonuna tıklayınca, 3.Kısım çalışma kitabındaki F, G, H ve I sütunlarının 43.satırından itibaren 57.satıra kadar,

MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasının F, G, H ve I sütunlarının 3.satırlarından itibaren aşağıya doğru (A Şefliği için 3-12.satırlar, 1.Kısım için 13-27.satırlar, 2.Kısım için 28-42.satırlar, 3.Kısım için 43-57.satırlar) aktarmasını istiyorum. MÜDÜRLÜK isimli çalışma kitabı açık, diğerleri kapalı olacak. 5 çalışma kitabı da Lokal Bilgisayalarına ortak alandaki klasöründe duruyor. Çalışma kitapları Ek'te sunulmuştur. Yapılabilir mi böyle bir şey?
Genişletmek için tıkla ...
Merhabalar, örnek dosyalar Ek'te sunulmuştur.
 

Ekli dosyalar

Kod: 
Sub veriCek()
    Dim adoCn As Object, rs As Object, i&, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")
    Sheets("ANA SAYFA").Range("F3:I57").ClearContents
    For i = 0 To 3
        strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1
        Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
        rs.Close
    Next i
    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub veriCek()
    Dim adoCn As Object, rs As Object, i&, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")
    Sheets("ANA SAYFA").Range("F3:I57").ClearContents
    For i = 0 To 3
        strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1
        Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
        rs.Close
    Next i
    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
Genişletmek için tıkla ...
Veysel bey emeğinize sağlık teşekkür ederim öncelikle. Ado olmadan sadece excel vba kullanarak bir şey yapılabilir mi acaba?
 
veyselemre' Alıntı:
Kod: 
Sub veriCek()
    Dim adoCn As Object, rs As Object, i&, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")
    Sheets("ANA SAYFA").Range("F3:I57").ClearContents
    For i = 0 To 3
        strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1
        Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
        rs.Close
    Next i
    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
Genişletmek için tıkla ...
Hocam nöbetçiyim o yüzden geç dönüş yapabildim. Mükemmel olmuş, ellerinize sağlık, Allah razı olsun, beni büyük yükten kurtardınız.
Tek yapamadığım, kodları MÜDÜRLÜK sayfasındaki A ŞEFLİĞİ AKTAR, 1.KISIM AKTAR, 2.KISIM AKTAR ve 3.KISIM AKTAR butonlarına nasıl tanımlayabilirim?
 
Veysel beyin önerdiği kodları tek bir butona atayıp kullanabilirsiniz.
 
Tek tek almak icin butonların hepsine calistir makrounu atayın.
Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
 
veyselemre' Alıntı:
Tek tek almak icin butonların hepsine calistir makrounu atayın.
Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
Genişletmek için tıkla ...
Elinize sağlık hocam, çok teşekkür ederim.
 
veyselemre' Alıntı:
Tek tek almak icin butonların hepsine calistir makrounu atayın.
Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1. KISIM", "2. KISIM", "3. KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "Select * From [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
End Sub
Genişletmek için tıkla ...

Veysel bey tekrar merhabalar. Hocam butonlara tek tek atadım çalışıyor ellerinize sağlık. Ama yeni bir gündem oluştu, kodlardan geliştirmeye çalıştım ancak yapamadım.

MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasındaki 4 butondan,

-"A Şefliği Aktar" butonuna tıklayınca; A ŞEFLİĞİ çalışma kitabının KADRO DIŞI sayfasındaki genel (B3:E3) hücrelerindeki verileri MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI sayfasındaki genel (B4:E4) hücrelerine, A ŞEFLİĞİ çalışma kitabının KADRO DIŞI sayfasındaki bulunmayan (B4:E4) hücrelerindeki verileri MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI sayfasındaki bulunmayan (B5:E5) hücrelerine, A ŞEFLİĞİ çalışma kitabının KADRO DIŞI sayfasındaki bulunmayanların beyanı (I3:O6) verilerini de MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI sayfasının (I3:06) hücrelerine aktarabilir mi?

Bu işlemi diğer veri çekilecek çalışma kitaplarının butonlarına tıklayınca da yapabilir mi?

Örnek çalışma kitapları Ek'te sunulmuştur.
 

Ekli dosyalar

"1.KISIM", "2.KISIM", "3.KISIM"
Yukarıdaki dosya isimlerinden boşlukları silin.

Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Dim dosyalar, satirlar, lst, ii&, iii&, son&
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1.KISIM", "2.KISIM", "3.KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "SELECT * FROM [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    With Sheets("KADRO DIŞI")

        strSQL = "Select IIF(IsNull(F1),0,F1), IIF(IsNull(F2),0,F2), IIF(IsNull(F3),0,F3), IIF(IsNull(F4),0,F4) " & _
                 "FROM [KADRO DIŞI$B3:E4] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1

        lst = Application.Transpose(rs.getrows)
        satirlar = Array(4, 11)
        For ii = 1 To 2
            For iii = 1 To 4
                .Cells(satirlar(ii - 1) + i, iii + 1).Value = lst(ii, iii)
            Next iii
        Next ii
        rs.Close

        son = .Cells(Rows.Count, "I").End(3).Row
        For ii = 3 To son
            If .Cells(ii, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).ClearContents
        Next ii

        strSQL = "Select * " & _
                 "FROM [KADRO DIŞI$I3:O100] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx] WHERE ISNULL(F1)=FALSE"
        rs.Open strSQL, adoCn, 1, 1
        .Cells(son + 1, "I").CopyFromRecordset rs

        son = .Cells(Rows.Count, "I").End(3).Row

        .Range("H3:O3").Copy
        .Range("H3:O" & son).PasteSpecial xlFormats
        Application.CutCopyMode = False

        .Sort.SortFields.Clear
        .Sort.SetRange .Range("I3:O" & son)
        .Sort.SortFields.Add .Columns("I"), CustomOrder:="A ŞEFLİĞİ,1.KISIM,2.KISIM,3.KISIM"
        .Sort.SortFields.Add .Columns("J")
        .Sort.SortFields.Add .Columns("K")
        .Sort.Apply

        son = .Cells(Rows.Count, "I").End(3).Row
        .Range(.Cells(son + 1, "H"), .Cells(Rows.Count, "O")).Delete shIft:=xlUp
        .Range("H3").Value = 1
        .Range("H3").AutoFill Destination:=.Range("H3:H" & son), Type:=xlFillSeries
    End With

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
    MsgBox "YOKLAMA ÇEKİLDİ."
End Sub
 
veyselemre' Alıntı:
"1.KISIM", "2.KISIM", "3.KISIM"
Yukarıdaki dosya isimlerinden boşlukları silin.

Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Dim dosyalar, satirlar, lst, ii&, iii&, son&
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1.KISIM", "2.KISIM", "3.KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "SELECT * FROM [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    With Sheets("KADRO DIŞI")

        strSQL = "Select IIF(IsNull(F1),0,F1), IIF(IsNull(F2),0,F2), IIF(IsNull(F3),0,F3), IIF(IsNull(F4),0,F4) " & _
                 "FROM [KADRO DIŞI$B3:E4] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1

        lst = Application.Transpose(rs.getrows)
        satirlar = Array(4, 11)
        For ii = 1 To 2
            For iii = 1 To 4
                .Cells(satirlar(ii - 1) + i, iii + 1).Value = lst(ii, iii)
            Next iii
        Next ii
        rs.Close

        son = .Cells(Rows.Count, "I").End(3).Row
        For ii = 3 To son
            If .Cells(ii, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).ClearContents
        Next ii

        strSQL = "Select * " & _
                 "FROM [KADRO DIŞI$I3:O100] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx] WHERE ISNULL(F1)=FALSE"
        rs.Open strSQL, adoCn, 1, 1
        .Cells(son + 1, "I").CopyFromRecordset rs

        son = .Cells(Rows.Count, "I").End(3).Row

        .Range("H3:O3").Copy
        .Range("H3:O" & son).PasteSpecial xlFormats
        Application.CutCopyMode = False

        .Sort.SortFields.Clear
        .Sort.SetRange .Range("I3:O" & son)
        .Sort.SortFields.Add .Columns("I"), CustomOrder:="A ŞEFLİĞİ,1.KISIM,2.KISIM,3.KISIM"
        .Sort.SortFields.Add .Columns("J")
        .Sort.SortFields.Add .Columns("K")
        .Sort.Apply

        son = .Cells(Rows.Count, "I").End(3).Row
        .Range(.Cells(son + 1, "H"), .Cells(Rows.Count, "O")).Delete shIft:=xlUp
        .Range("H3").Value = 1
        .Range("H3").AutoFill Destination:=.Range("H3:H" & son), Type:=xlFillSeries
    End With

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
    MsgBox "YOKLAMA ÇEKİLDİ."
End Sub
Genişletmek için tıkla ...

Veysel bey elinize emeğinize sağlık, Allah razı olsun. 2 sorun oluştu ama bu şekilde de kullanabilirim.
1) A ŞEFLİĞİ, 1.KISIM 2.KISIM ya da 3.KISIM çalışma kitaplarının herhangi birinin KADRO DIŞI sayfasında BULUNMAYAN (B4:E4) yok ise haliyle BULUNMAYAN BEYANI (H3:03'ten itibaren aşağıya doğru) başlıklar hariç veri olmuyor ya, İLK OLARAK bulunmayanı 0 (sıfır) olanın butonuna basınca MÜDÜRLÜK çalışma kitabının KADRO DIŞI sayfasının H2 hücresindeki başlık olan S.NO. ifadesini kaldırıp 0 (sıfır) yapıyor. (FOTOĞRAF-1)

2) Bir de MÜDÜRLÜK çalışma sayfasındaki butonlardan herhangi birine tıklayınca, KADRO DIŞI sayfasının H3:03 satırından itibaren aşağıya doğru çektiği veriyi, MÜDÜRLÜK çalışma sayfasının ANA SAYFASINDA da gösteriyor ama yan sayfaya tıklayıp dönünce geçiyor. (FOTOĞRAF-2)

A Şefliği ile 1.KISIM çalışma kitaplarının KADRO DIŞI sayfasındaki bulunmayanları sıfıra indirerek örnek dosya ekledim hocam.
 

Ekli dosyalar

Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Dim dosyalar, satirlar, lst, ii&, iii&, son&
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1.KISIM", "2.KISIM", "3.KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "SELECT * FROM [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    With Sheets("KADRO DIŞI")
        .Select
        strSQL = "Select IIF(IsNull(F1),0,F1), IIF(IsNull(F2),0,F2), IIF(IsNull(F3),0,F3), IIF(IsNull(F4),0,F4) " & _
                 "FROM [KADRO DIŞI$B3:E4] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1

        lst = Application.Transpose(rs.getrows)
        satirlar = Array(4, 11)
        For ii = 1 To 2
            For iii = 1 To 4
                .Cells(satirlar(ii - 1) + i, iii + 1).Value = lst(ii, iii)
            Next iii
        Next ii
        rs.Close

        If .Cells(3, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).ClearContents
        son = .Cells(Rows.Count, "I").End(3).Row
        For ii = son To 4 Step -1
            If .Cells(ii, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).Delete shift:=xlUp
        Next ii

        strSQL = "Select * " & _
                 "FROM [KADRO DIŞI$I3:O100] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx] WHERE ISNULL(F1)=FALSE"
        rs.Open strSQL, adoCn, 1, 1
        .Cells(son + 1, "I").CopyFromRecordset rs

        son = .Cells(Rows.Count, "I").End(3).Row

        If son > 3 Then
            .Range("H3:O3").Copy
            .Range("H3:O" & son).PasteSpecial xlFormats
            Application.CutCopyMode = False

            .Sort.SortFields.Clear
            .Sort.SetRange .Range("I3:O" & son)
            .Sort.SortFields.Add .Range("I3"), CustomOrder:="A ŞEFLİĞİ,1.KISIM,2.KISIM,3.KISIM"
            .Sort.Apply
        End If
        son = .Cells(Rows.Count, "I").End(3).Row
        If son = 2 Then son = 3
        .Range(.Cells(son + 1, "H"), .Cells(Rows.Count, "O")).Delete shift:=xlUp
        If son > 3 Then .Range("H3").AutoFill Destination:=.Range("H3:H" & son), Type:=xlFillSeries
        .Range("H3").Select
        Sheets("ANA SAYFA").Select
    End With

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
    MsgBox "YOKLAMA ÇEKİLDİ."
End Sub
 
veyselemre' Alıntı:
Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Dim dosyalar, satirlar, lst, ii&, iii&, son&
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1.KISIM", "2.KISIM", "3.KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "SELECT * FROM [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    With Sheets("KADRO DIŞI")
        .Select
        strSQL = "Select IIF(IsNull(F1),0,F1), IIF(IsNull(F2),0,F2), IIF(IsNull(F3),0,F3), IIF(IsNull(F4),0,F4) " & _
                 "FROM [KADRO DIŞI$B3:E4] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1

        lst = Application.Transpose(rs.getrows)
        satirlar = Array(4, 11)
        For ii = 1 To 2
            For iii = 1 To 4
                .Cells(satirlar(ii - 1) + i, iii + 1).Value = lst(ii, iii)
            Next iii
        Next ii
        rs.Close

        If .Cells(3, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).ClearContents
        son = .Cells(Rows.Count, "I").End(3).Row
        For ii = son To 4 Step -1
            If .Cells(ii, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).Delete shift:=xlUp
        Next ii

        strSQL = "Select * " & _
                 "FROM [KADRO DIŞI$I3:O100] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx] WHERE ISNULL(F1)=FALSE"
        rs.Open strSQL, adoCn, 1, 1
        .Cells(son + 1, "I").CopyFromRecordset rs

        son = .Cells(Rows.Count, "I").End(3).Row

        If son > 3 Then
            .Range("H3:O3").Copy
            .Range("H3:O" & son).PasteSpecial xlFormats
            Application.CutCopyMode = False

            .Sort.SortFields.Clear
            .Sort.SetRange .Range("I3:O" & son)
            .Sort.SortFields.Add .Range("I3"), CustomOrder:="A ŞEFLİĞİ,1.KISIM,2.KISIM,3.KISIM"
            .Sort.Apply
        End If
        son = .Cells(Rows.Count, "I").End(3).Row
        If son = 2 Then son = 3
        .Range(.Cells(son + 1, "H"), .Cells(Rows.Count, "O")).Delete shift:=xlUp
        If son > 3 Then .Range("H3").AutoFill Destination:=.Range("H3:H" & son), Type:=xlFillSeries
        .Range("H3").Select
        Sheets("ANA SAYFA").Select
    End With

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
    MsgBox "YOKLAMA ÇEKİLDİ."
End Sub
Genişletmek için tıkla ...
Veysel bey ellerinize sağlık, çok teşekkür ederim.
 
Veysel hocam ve kıymetli diğer excel üstadları. Parça parça sormuş oluyorum ama inanın kasıtlı değil. Yeni bir başlık mı açmalıyım bilemedim, önce buradan yazayım dedim.
Veysel Bey'in yapmış olduğu "veriCek" programı sayesinde, MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasındaki 4 farklı buton, 4 farklı çalışma kitabından veri çekiyor. Elinize kolunuza sağlık Veysel Bey, Allah razı olsun.

MÜDÜRLÜK isimli çalışma kitabıma çekilen veriler, yine MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasındaki RAPORA AKTAR butonuna tıklayınca;
1) RAPOR isimli çalışma sayfasındaki gibi yeni bir excel çalışma kitabı oluşturup [yeni excel çalışma kitabının adını, içinde bulunulan tarihin yoklaması yapacağım (11.11.2020 YOKLAMA)] buraya aktarabilir mi? Bunu her gün için tekrarlayabilir mi? (Ben ÇOKEĞERSAY formülü ve filtreleme yöntemi ile RAPORA aktarıyorum ama daha hızlı olabilmek için kodlarla yapılabilir mi? )
2) MÜDÜRLÜK isimli çalışma kitabının ANA SAYFA isimli sayfasının (F3:F) hücrelerindeki dolu olan verileri RAPOR isimli çalışma kitabının SAYISAL BEYAN isimli sayfasının (A8:A32) hücrelerindeki aynı verinin karşısına sayı olarak atabilir mi?
(ÖRNEK: MÜDÜRLÜK-ANA SAYFA'da Hasan VELİ (E4) hastanedeymiş.(F4) Hasan VELİ'nin görevi PER.(C4)
RAPOR çalışma kitabının SAYISAL BEYAN sayfasının A16 (HASTANE) ile C16 (PER.) kesişimi 1 olmalı)
3) MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI isimli sayfasının (B3:O3) sütunundan itibaren aşağıya doğru (B3:0) hücrelerdeki verileri, kinci sorumdaki gibi RAPOR çalışma kitabının SAYISAL BEYAN sayfasındaki aynı verilerin kesiştiği hücreye sayı olarak atabilir mi?
4) MÜDÜRLÜK isimli çalışma kitabının ANA SAYFA isimli sayfasının (F3:F500) hücrelerinde veri var ise, verini olduğu (B:O) hücrelerini alıp RAPOR isimli çalışma kitabının İSİM BEYANI isimli sayfasına aktarabilir mi?
5) MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI isimli sayfasının (B3:O3) sütunundan itibaren aşağıya doğru dolu olan (B3:0) hücrelerini yine alıp RAPOR isimli çalışma kitabının İSİM BEYANI isimli sayfasına aktarabilir mi?
 

Ekli dosyalar

Szg15' Alıntı:
Veysel hocam ve kıymetli diğer excel üstadları. Parça parça sormuş oluyorum ama inanın kasıtlı değil. Yeni bir başlık mı açmalıyım bilemedim, önce buradan yazayım dedim.
Veysel Bey'in yapmış olduğu "veriCek" programı sayesinde, MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasındaki 4 farklı buton, 4 farklı çalışma kitabından veri çekiyor. Elinize kolunuza sağlık Veysel Bey, Allah razı olsun.

MÜDÜRLÜK isimli çalışma kitabıma çekilen veriler, yine MÜDÜRLÜK isimli çalışma kitabımın ANA SAYFA isimli çalışma sayfasındaki RAPORA AKTAR butonuna tıklayınca;
1) RAPOR isimli çalışma sayfasındaki gibi yeni bir excel çalışma kitabı oluşturup [yeni excel çalışma kitabının adını, içinde bulunulan tarihin yoklaması yapacağım (11.11.2020 YOKLAMA)] buraya aktarabilir mi? Bunu her gün için tekrarlayabilir mi? (Ben ÇOKEĞERSAY formülü ve filtreleme yöntemi ile RAPORA aktarıyorum ama daha hızlı olabilmek için kodlarla yapılabilir mi? )
2) MÜDÜRLÜK isimli çalışma kitabının ANA SAYFA isimli sayfasının (F3:F) hücrelerindeki dolu olan verileri RAPOR isimli çalışma kitabının SAYISAL BEYAN isimli sayfasının (A8:A32) hücrelerindeki aynı verinin karşısına sayı olarak atabilir mi?
(ÖRNEK: MÜDÜRLÜK-ANA SAYFA'da Hasan VELİ (E4) hastanedeymiş.(F4) Hasan VELİ'nin görevi PER.(C4)
RAPOR çalışma kitabının SAYISAL BEYAN sayfasının A16 (HASTANE) ile C16 (PER.) kesişimi 1 olmalı)
3) MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI isimli sayfasının (B3:O3) sütunundan itibaren aşağıya doğru (B3:0) hücrelerdeki verileri, kinci sorumdaki gibi RAPOR çalışma kitabının SAYISAL BEYAN sayfasındaki aynı verilerin kesiştiği hücreye sayı olarak atabilir mi?
4) MÜDÜRLÜK isimli çalışma kitabının ANA SAYFA isimli sayfasının (F3:F500) hücrelerinde veri var ise, verini olduğu (B:O) hücrelerini alıp RAPOR isimli çalışma kitabının İSİM BEYANI isimli sayfasına aktarabilir mi?
5) MÜDÜRLÜK isimli çalışma kitabının KADRO DIŞI isimli sayfasının (B3:O3) sütunundan itibaren aşağıya doğru dolu olan (B3:0) hücrelerini yine alıp RAPOR isimli çalışma kitabının İSİM BEYANI isimli sayfasına aktarabilir mi?
Genişletmek için tıkla ...

konu güncel kıymetli üstadlar..
 
veyselemre' Alıntı:
Kod: 
Sub calistir()
    Select Case Application.Caller
        Case "1 Dikdörtgen": Call veriCek(0)
        Case "2 Dikdörtgen": Call veriCek(1)
        Case "3 Dikdörtgen": Call veriCek(2)
        Case "4 Dikdörtgen": Call veriCek(3)
    End Select
End Sub

Sub veriCek(i As Long)
    Dim adoCn As Object, rs As Object, kaynakAdres, hedefAdres, strSQL$
    Dim dosyalar, satirlar, lst, ii&, iii&, son&
    Set adoCn = CreateObject("ADODB.Connection")
    adoCn.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCn.Properties("Data Source") = ThisWorkbook.FullName
    adoCn.Properties("Extended Properties") = "Excel 12.0; HDR=No"
    adoCn.Open
    Set rs = CreateObject("Adodb.RecordSet")
    dosyalar = Array("A ŞEFLİĞİ", "1.KISIM", "2.KISIM", "3.KISIM")
    kaynakAdres = Array("F3:I12", "F3:I17", "F3:I17", "F3:I17")
    hedefAdres = Array("F3:I12", "F13:I27", "F28:I42", "F43:I57")

    Sheets("ANA SAYFA").Range(hedefAdres(i)).ClearContents

    strSQL = "SELECT * FROM [ANA SAYFA$" & kaynakAdres(i) & "] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
             dosyalar(i) & ".xlsx]"
    rs.Open strSQL, adoCn, 1, 1
    Sheets("ANA SAYFA").Range(hedefAdres(i)).CopyFromRecordset rs
    rs.Close

    With Sheets("KADRO DIŞI")
        .Select
        strSQL = "Select IIF(IsNull(F1),0,F1), IIF(IsNull(F2),0,F2), IIF(IsNull(F3),0,F3), IIF(IsNull(F4),0,F4) " & _
                 "FROM [KADRO DIŞI$B3:E4] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx]"
        rs.Open strSQL, adoCn, 1, 1

        lst = Application.Transpose(rs.getrows)
        satirlar = Array(4, 11)
        For ii = 1 To 2
            For iii = 1 To 4
                .Cells(satirlar(ii - 1) + i, iii + 1).Value = lst(ii, iii)
            Next iii
        Next ii
        rs.Close

        If .Cells(3, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).ClearContents
        son = .Cells(Rows.Count, "I").End(3).Row
        For ii = son To 4 Step -1
            If .Cells(ii, "I") = dosyalar(i) Then .Cells(ii, "I").Resize(, 7).Delete shift:=xlUp
        Next ii

        strSQL = "Select * " & _
                 "FROM [KADRO DIŞI$I3:O100] IN '' [Excel 12.0;HDR=No;Database=" & ThisWorkbook.Path & "\" & _
                 dosyalar(i) & ".xlsx] WHERE ISNULL(F1)=FALSE"
        rs.Open strSQL, adoCn, 1, 1
        .Cells(son + 1, "I").CopyFromRecordset rs

        son = .Cells(Rows.Count, "I").End(3).Row

        If son > 3 Then
            .Range("H3:O3").Copy
            .Range("H3:O" & son).PasteSpecial xlFormats
            Application.CutCopyMode = False

            .Sort.SortFields.Clear
            .Sort.SetRange .Range("I3:O" & son)
            .Sort.SortFields.Add .Range("I3"), CustomOrder:="A ŞEFLİĞİ,1.KISIM,2.KISIM,3.KISIM"
            .Sort.Apply
        End If
        son = .Cells(Rows.Count, "I").End(3).Row
        If son = 2 Then son = 3
        .Range(.Cells(son + 1, "H"), .Cells(Rows.Count, "O")).Delete shift:=xlUp
        If son > 3 Then .Range("H3").AutoFill Destination:=.Range("H3:H" & son), Type:=xlFillSeries
        .Range("H3").Select
        Sheets("ANA SAYFA").Select
    End With

    adoCn.Close
    Set rs = Nothing
    Set adoCn = Nothing
    MsgBox "YOKLAMA ÇEKİLDİ."
End Sub

Veysel bey merhaba. Yazdığınız kodları; belgeleri, belge isimleri, sayfa isimleri vb.her şeyi birebir aynı olan, sadece office sürümü 2016 olan (foruma eklediğim örnek belgeler 2007 sürümde hazırlamıştım) bilgisayarda kopyala yapıştır yaptım.
calistir makrosunu yine sizin dediğiniz gibi 4 farklı dikdörtgene atadım ama "Run-time error 13:  Type mismatch" şeklinde hata veriyor. Case "1 Dikdörtgen" kısmını sarı renk yapıyor. Dikdörtgenleri düğme ile değiştirdim, calistir makrosunda dikdörtgen ifadelerini Düğme yaptım ama bir türlü çalıştıramadım hocam..  Dikdörtgene tıklamıyor bile, F5'e basınca yukarıda yazdığım hata çıkıyor. Neyi yanlış yapıyor olabilirim sizce?
Genişletmek için tıkla ...
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst