Soru Veri Aktarma

Szg15 · 24 Kasım 2020

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

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 · 25 Kasım 2020

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

Szg15 · 25 Kasım 2020

Korhan Ayhan' Alıntı:
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 · 25 Kasım 2020

Application.Caller kullanıldığı için kodu buton üzerinden çalıştırmalısınız.

Szg15 · 25 Kasım 2020

Korhan Ayhan' Alıntı:
Application.Caller kullanıldığı için kodu buton üzerinden çalıştırmalısınız.

1 Düğme
2 Düğme
3 Düğme
4 Düğme
Şeklinde mi?

Korhan Ayhan' Alıntı:
Application.Caller kullanıldığı için kodu buton üzerinden çalıştırmalısınız.

1 Dikdörtgen yerine ne yazmalıyım hocam?

Korhan Ayhan · 25 Kasım 2020

Sayfaya eklediğiniz düğmelerin adı nedir?

Szg15 · 25 Kasım 2020

Korhan Ayhan' Alıntı:
Sayfaya eklediğiniz düğmelerin adı nedir?

Düğme 1
Düğme 2
Düğme 3
Düğme 4

Makro atamaya tıklayınca, Makro adı olarak Düğme1_Tıkla, Düğme2_Tıkla... şeklinde yazıyor

Korhan Ayhan · 25 Kasım 2020

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)

Szg15 · 25 Kasım 2020

Korhan Ayhan' Alıntı:
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 · 25 Kasım 2020

Ben bir şey yapmadım.

Asıl çözümü @veyselemre bey yaptı. Ona teşekkür edin.

Szg15 · 25 Kasım 2020

Korhan Ayhan' Alıntı:
Ben bir şey yapmadım.

Asıl çözümü @veyselemre bey yaptı. Ona teşekkür edin.

Veysel bey’den Allah razı olsun. Onun sayesinde her gün 2 saatlik iş yüküm 1 dakikaya düştü, kalan süre de personelin lehine olacak şekilde kontrole ayırmamı sağladı. Sağlıcakla kıymetli üstadlar.

Szg15 · 7 Aralık 2020

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

@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.

Szg15 · 9 Aralık 2020

Szg15' Alıntı:
@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

Soru Veri Aktarma

Szg15

Korhan Ayhan

Administrator

Szg15

Korhan Ayhan

Administrator

Szg15

Korhan Ayhan

Administrator

Szg15

Korhan Ayhan

Administrator

Szg15

Korhan Ayhan

Administrator

Szg15

Szg15

Szg15