Soru Veri Aktarma

Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
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
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?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Sayfaya eklediğiniz nesnelerin adını kod içindeki gibi düzenlemeniz gerekiyor.

1 Dikdörtgen
2 Dikdörtgen
3 Dikdörtgen
4 Dikdörtgen
 
Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
Sayfaya eklediğiniz nesnelerin adını kod içindeki gibi düzenlemeniz gerekiyor.

1 Dikdörtgen
2 Dikdörtgen
3 Dikdörtgen
4 Dikdörtgen
Aynen dediğiniz şekilde yapıyorum korhan bey, dikdörtgenlere calistir makrosunu da atıyorum ama bir türlü çalıştıramadım. Tıklanmıyor dikdörtgene; kod sayfasından f5 yaptığım zaman yukarıdaki hatayı yazıyor..
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Application.Caller kullanıldığı için kodu buton üzerinden çalıştırmalısınız.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Sayfaya eklediğiniz düğmelerin adı nedir?
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
O zaman kodun içindeki aşağıdaki ifade yerine bir sonraki satırı uygulayıp deneyiniz.

Eski hali;
Case "1 Dikdörtgen": Call veriCek(0)

Olması gereken;
Case "Düğme 1": Call veriCek(0)
 
Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
O zaman kodun içindeki aşağıdaki ifade yerine bir sonraki satırı uygulayıp deneyiniz.

Eski hali;
Case "1 Dikdörtgen": Call veriCek(0)

Olması gereken;
Case "Düğme 1": Call veriCek(0)
Korhan bey elinize sağlık. Çalıştı. O kadar denemiştim Düğme 1, 1 Düğme, Düğme_1 Tıkla, Tıklat.. Saygılar, iyi ve sağlıklı akşamlar.
 

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
41,325
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Ben bir şey yapmadım.

Asıl çözümü @veyselemre bey yaptı. Ona teşekkür edin.
 
Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
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 hocam KADRO DIŞI sayfalarından B3:E4 aralığını getiriyor ya, B3:G4 aralıklarını çekebilir miyiz? Bir de yine KADRO DIŞI sayfalarının H3:O aralıklarını getiriyor ya, I3:Q aralıklarını çekebilir miyiz? Bunlar için nasıl bir değişiklik yapmalıyız, günlerdir uğraşıyorum çözemedim, yardımcı olursanız çok memnun olurum.
 
Katılım
27 Ekim 2017
Mesajlar
59
Excel Vers. ve Dili
2010 turkce
@veyselemre hocam KADRO DIŞI sayfalarından B3:E4 aralığını getiriyor ya, B3:G4 aralıklarını çekebilir miyiz? Bir de yine KADRO DIŞI sayfalarının H3:O aralıklarını getiriyor ya, I3:Q aralıklarını çekebilir miyiz? Bunlar için nasıl bir değişiklik yapmalıyız, günlerdir uğraşıyorum çözemedim, yardımcı olursanız çok memnun olurum.
@Korhan Ayhan hocam siz yardımcı olabilir misiniz? Veysel bey müsait değil sanırım
 
Üst