Kapalı dosyadan buton ile veri alma.

Haluk · 14 Mayıs 2021

Veri girişi yapılan dosyalarda, "veri doğrulama" fonksiyonuyla doğru tipte veri girişi yapılmasını zorlayabilirsiniz....

.

Korhan Ayhan · 14 Mayıs 2021

Ben IMEX eklenmiş kod bloğunu paylaşıyorum. Bir ara denersiniz.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim S1 As Worksheet, S2 As Worksheet, Baglanti As Object, Kayit_Seti As Object
    Dim Sorgu As String, Yol As String, Dosya As String
    Dim Veri As Range, Alan As Range, Ay As String, Zaman As Double
    
    Zaman = Timer
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("AYLIK")
    Set Baglanti = CreateObject("Adodb.Connection")
    Set Kayit_Seti = CreateObject("Adodb.Recordset")
    
    S1.Range("B7:K2506").ClearContents
    
    S1.Cells.EntireRow.Hidden = False
    
    Ay = S1.Range("K4").Value
    
    Yol = ThisWorkbook.Path & Application.PathSeparator
    
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
            Yol & Dosya & ";Extended Properties=""Excel 12.0;Hdr=No;Imex=1"""
            
            Sorgu = "Select Ucase(F1),Ucase(F2),F3,F4,F5,F6,F7,F8,Ucase(F9),Ucase(F10) From [GÜNLÜK$B7:K]"
            
            Kayit_Seti.Open Sorgu, Baglanti, 1, 1
            
            If Kayit_Seti.RecordCount > 0 Then
                S1.Cells(S1.Rows.Count, "B").End(3)(2, 1).CopyFromRecordset Kayit_Seti
            End If
            
            
            If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
            If Baglanti.State <> 0 Then Baglanti.Close
        End If
    
        Dosya = Dir
    Wend
    
    S1.Range("G7:H2506").NumberFormat = "hh:mm:ss"
    
    Set Baglanti = Nothing
    Set Kayit_Seti = Nothing
    
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
    
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
    
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
    
    Set S1 = Nothing
    Set S2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Ayhan · 14 Mayıs 2021

Bu da dosyaları arkaplanda açarak verileri aktarıyor. Sorunlu hücreleri olduğu gibi aktarmaktadır. Bu sebeple kontrol etmenizde fayda var.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet, Zaman As Double
    Dim Yol As String, Dosya As String, Son As Long
    Dim Ay As String, Veri As Range, Alan As Range

    Zaman = Timer

    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.DisplayAlerts = 0
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("AYLIK")
    
    S1.Range("B7:K2506").ClearContents
    
    S1.Cells.EntireRow.Hidden = False
    
    Yol = K1.Path & Application.PathSeparator
    
    Ay = S1.Range("K4").Value
    
    Dosya = Dir(Yol & "*.xls*")
    
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("GÜNLÜK")
            
            Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
            
            If Son > 6 Then
                S2.Range("B7:K" & Son).Copy
                S1.Cells(S1.Rows.Count, 2).End(3).Offset(1).PasteSpecial
            End If
            
            K2.Close False
        End If
        Dosya = Dir
    Wend
        
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
    
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
    
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
    
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
    
    S1.Range("A7").Select
    
    Set S1 = Nothing
    Set K1 = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
            
    Application.DisplayAlerts = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    MsgBox "Aktarım işlemi tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Grknpkdzn · 14 Mayıs 2021

Korhan Ayhan' Alıntı:

Bu da dosyaları arkaplanda açarak verileri aktarıyor. Sorunlu hücreleri olduğu gibi aktarmaktadır. Bu sebeple kontrol etmenizde fayda var.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet, Zaman As Double
    Dim Yol As String, Dosya As String, Son As Long
    Dim Ay As String, Veri As Range, Alan As Range

    Zaman = Timer

    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.DisplayAlerts = 0
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("AYLIK")
   
    S1.Range("B7:K2506").ClearContents
   
    S1.Cells.EntireRow.Hidden = False
   
    Yol = K1.Path & Application.PathSeparator
   
    Ay = S1.Range("K4").Value
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("GÜNLÜK")
           
            Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
           
            If Son > 6 Then
                S2.Range("B7:K" & Son).Copy
                S1.Cells(S1.Rows.Count, 2).End(3).Offset(1).PasteSpecial
            End If
           
            K2.Close False
        End If
        Dosya = Dir
    Wend
       
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
   
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
   
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
   
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
   
    S1.Range("A7").Select
   
    Set S1 = Nothing
    Set K1 = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
           
    Application.DisplayAlerts = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    MsgBox "Aktarım işlemi tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Bey Günaydın.
Ellerinize sağlık on numara beş yıldız çalışıyor...
Çok teşekkür ederim. Allah razı olsun hepinizden..

Grknpkdzn · 14 Mayıs 2021

Korhan Ayhan' Alıntı:

Bu da dosyaları arkaplanda açarak verileri aktarıyor. Sorunlu hücreleri olduğu gibi aktarmaktadır. Bu sebeple kontrol etmenizde fayda var.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet, Zaman As Double
    Dim Yol As String, Dosya As String, Son As Long
    Dim Ay As String, Veri As Range, Alan As Range

    Zaman = Timer

    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.DisplayAlerts = 0
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("AYLIK")
   
    S1.Range("B7:K2506").ClearContents
   
    S1.Cells.EntireRow.Hidden = False
   
    Yol = K1.Path & Application.PathSeparator
   
    Ay = S1.Range("K4").Value
   
    Dosya = Dir(Yol & "*.xls*")
   
    While Dosya <> ""
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("GÜNLÜK")
           
            Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
           
            If Son > 6 Then
                S2.Range("B7:K" & Son).Copy
                S1.Cells(S1.Rows.Count, 2).End(3).Offset(1).PasteSpecial
            End If
           
            K2.Close False
        End If
        Dosya = Dir
    Wend
       
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
   
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
   
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
   
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
   
    S1.Range("A7").Select
   
    Set S1 = Nothing
    Set K1 = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
           
    Application.DisplayAlerts = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    MsgBox "Aktarım işlemi tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Korhan Bey,
Müsait olunca,
Yukarıdaki kod demetinde yer alan kodlarda, "Burada bunu yaptırıyoruz." - "Buradan bunu çektiriyoruz" - "Burada şunu hedefliyoruz" gibi açıklama ekleyebilirseniz, bende denemelerimde araştırarak ve buna bakarak kendimi geliştirmek isterim.

Korhan Ayhan · 14 Mayıs 2021

Satır aralarına gerekli açıklamaları ekledim.

C++:

Option Explicit

Sub Mesai_Tablolarini_Iceri_Aktar()
    Rem Bu bölümde makro içinde kullanacağımız değişkenleri tanımlıyoruz.
    Dim K1 As Workbook, S1 As Worksheet
    Dim K2 As Workbook, S2 As Worksheet, Zaman As Double
    Dim Yol As String, Dosya As String, Son As Long
    Dim Ay As String, Veri As Range, Alan As Range

    Rem İşlem süresini tespit edebilmek için bir zaman sayacı başlatıyoruz.
    Zaman = Timer

    Rem Ekran hareketlerini kapatıyoruz, hesaplama yöntemini elle şeklinde ayarlıyoruz, ekran uyarı mesajlarını kapatıyoruz.
    Application.ScreenUpdating = 0
    Application.Calculation = -4135
    Application.DisplayAlerts = 0
   
    Rem Çalışma kitabını ve işlem yapılacak sayfayı kısa isimle hafızaya alıyoruz.
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("AYLIK")
   
    Rem Verilerin aktarılacağı alandaki eski bilgileri temizliyoruz.
    S1.Range("B7:K2506").ClearContents
   
    Rem Sayfadaki gizli satırları görünür yapıyoruz.
    S1.Cells.EntireRow.Hidden = False
   
    Rem Verilerin alınacağı dosyaların bulunduğu klasörü tanımlıyoruz.
    Yol = K1.Path & Application.PathSeparator
   
    Rem Hangi aya ait dosyaların aktarılacağını belirlemek üzere Ay tanımlamasını yapıyoruz.
    Ay = S1.Range("K4").Value
   
    Rem Klasördeki excel uzantılı dosyaları kontrol ediyoruz.
    Dosya = Dir(Yol & "*.xls*")
   
    Rem Eğer klasörde excel uzantılı dosya varsa işleme devam et diyoruz.
    While Dosya <> ""
        Rem Dosyanın adındaki ilk boşluk karakterine kadar olan kısmı baz alarak Ay kontrolü yapıyoruz.
        If UCase(Replace(Replace(Format(Split(Dosya, " ")(0), "mmmm"), "ı", "I"), "i", "İ")) = Ay Then
            Rem Eğer dosya istediğimiz aya ait bir dosya ise dosyayı gizli biçimde açıyoruz. Dosyayı ve aktarılacak sayfa adını hafızaya alıyoruz.
            Set K2 = GetObject(Yol & Dosya)
            Set S2 = K2.Sheets("GÜNLÜK")
           
            Rem İlgili sayfadaki son dolu satırı tespit ediyoruz.
            Son = S2.Cells(S2.Rows.Count, 2).End(3).Row
           
            Rem Eğer son satır numarası 6'dan büyükse verileri kopyalayarak hedef sayfaya yapıştırıyoruz.
            If Son > 6 Then
                S2.Range("B7:K" & Son).Copy
                S1.Cells(S1.Rows.Count, 2).End(3).Offset(1).PasteSpecial
            End If
           
            Rem Açtığımız dosyayı işlemi bittiği için kaydetmeden kapatıyoruz.
            K2.Close False
        End If
        Rem Klasördeki diğer excel dosyalarını kontrol etmeye devam ediyoruz.
        Dosya = Dir
        Rem Eğer klasördeki excel dosyaları bittiyse döngüyü tamamlıyoruz.
    Wend
   
    Rem Bu bölümde ise tablomuzun satır sayısını arttırdığımız için boş olan satırları görüntü kirliliğini önlemek adına gizlemek için döngü ile kontrol ediyoruz.
    For Each Veri In S1.Range("B7:B2506")
        If Veri.Value = "" Then
            If Alan Is Nothing Then
                Set Alan = Veri
            Else
                Set Alan = Union(Alan, Veri)
            End If
        End If
    Next
   
    Rem Eğer veri aktarılan alanda boş satır tespit edildiyse gizliyoruz.
    If Not Alan Is Nothing Then Alan.EntireRow.Hidden = True
   
    Rem Bu bölümde ise verilerin başındaki tek tırnak sembolünden verileri arındırıyoruz.
    Rem Bunun için I sütunundaki verileri kopyalayıp yeni boş bir excel sayfasına yapıştırıyoruz.
    Rem Sonra bu yeni sayfaya yapıştırdığımız verileri kopyalayarak I sütununa değer olarak yeniden yapıştırıyoruz.
    Rem Böylece tek tırnak sembolünden verileri arındırmış oluyoruz. Sonra eklediğimiz bu geçici sayfayı siliyoruz.
    S1.Range("I7:I2506").Copy
    Set S2 = Worksheets.Add
    S2.Range("A1").PasteSpecial xlPasteValues
    S2.Range("A1:A2500").Copy S1.Range("I7")
    Application.DisplayAlerts = False
    S2.Delete
    Application.DisplayAlerts = True
   
    With S1.Range("I7:I2506")
        .Value = .Value
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = 1
    End With
   
    Rem Kopyala yapıştır işlemlerinde excel otomatik alan seçtiği için hoş bir görüntü oluşmamaktadır. Bunu önlemek için biz aktif hücreyi A7 olarak belirliyoruz.
    S1.Range("A7").Select
   
    Rem Makroda kullanmak üzere hafızaya aldığımız kısa isimleri hafızadan kaldırıyoruz.
    Set S1 = Nothing
    Set K1 = Nothing
    Set S2 = Nothing
    Set K2 = Nothing
           
    Rem Ekran hareketlerini açıyoruz, hesaplama yöntemini otomatik şeklinde ayarlıyoruz, ekran uyarı mesajlarını açıyoruz.
    Application.DisplayAlerts = 1
    Application.Calculation = -4105
    Application.ScreenUpdating = 1

    Rem Kullanıcıya yapılan işlemle ilgili bilgilendirme mesajı veriyoruz.
    MsgBox "Aktarım işlemi tamamlanmıştır." & vbCr & vbCr & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
End Sub

Grknpkdzn · 22 Mayıs 2021

Korhan Hocam selamlar..
Sizin verdiğiniz bilgilerle yapmaya çalıştım ama beceremedim.!
Şu aşağıdaki durum hakkında yardımlarınızı rica ederim.
"Firma ve Fiyat Bilgileri" dosyasına "B" hücresine talep numarasını yazıp "İçeri Aktar..." tuşuna bastığımda
"Gelen Malzeme Talep Çizelgesi" dosyasına bağlanarak girmiş olduğum talep numarasını bulup, o numarada geçen tüm satırları alıp listelemesini istiyorum.
"Firma ve Fiyat Bilgileri" dosyasında ki başlıklara karşılık gelen sütunlar da şöyle;
C Sütunu (Firmalar) -> "L" sütununa (Tedarikçi Firmalar)
F Sütunu (Malzeme Adı) -> "F" sütununa (Özellikler)
H Sütunu (Birim) -> "K" sütununa (Birim)
I Sütunu (Mik.) -> "J" Sütununa ( Talep Edil. Mik.)

Korhan Ayhan · 24 Mayıs 2021

Merhaba,

Bahsettiğiniz sütunların dışında kalan sütunlara bir işlem yapılmayacak mı? Bu sütunlarda sabit veriler mi var?

Ayrıca B sütununa yazmak yerine mesela sabit bir hücre (Q1 gibi) kullansanız daha sağlıklı olmaz mı?

Ek olarak Talep No yazdınız ve veriler aktarıldı. Sonra başka bir Talep No yazıp aktarmak istediğinizde senaryo ne olacak? Bir önceki aktarım yapılan veriler silinecek mi? Ya da bir önceki veriler silinmeden altına devam mı edilecek?

Grknpkdzn · 24 Mayıs 2021

Korhan Ayhan' Alıntı:
Merhaba,

Bahsettiğiniz sütunların dışında kalan sütunlara bir işlem yapılmayacak mı? Bu sütunlarda sabit veriler mi var?

Ayrıca B sütununa yazmak yerine mesela sabit bir hücre (Q1 gibi) kullansanız daha sağlıklı olmaz mı?

Ek olarak Talep No yazdınız ve veriler aktarıldı. Sonra başka bir Talep No yazıp aktarmak istediğinizde senaryo ne olacak? Bir önceki aktarım yapılan veriler silinecek mi? Ya da bir önceki veriler silinmeden altına devam mı edilecek?

Korhan hocam şöyle,
Bahsettiğimiz sütunların dışındakilere farklı veriler elle giriliyor olacak.

"B" stütununa (Talep No) yazılması elzemdir.

Senaryo şöyle;
3725 yazdım. Hemen altına 3726 yı yazdım diyelim.
3725 için ilgili başlıklar altına yer alan 3 kalem bilgisini,
3726 için ilgili başlıklar altında yer alan 2 kalem bilgisini listeliyecek. Yani ben hangi sipariş numarasını istemişsem ilgili numarada kaç kalem bilgi varsa silinmeden ekleye ekleye devam edicem..

Korhan Ayhan · 24 Mayıs 2021

Deneyiniz.

İki dosyanız aynı klasör içinde olacak şekilde ayarladıktan sonra kodu deneyiniz.

Yok ben dosyaları ayrı klasörlerde tutarak kodu çalıştırmak istiyorum derseniz kod içindeki aşağıdaki satıra kapalı dosyanızın yolunu yazınız.

Yol = ThisWorkbook.Path & Application.PathSeparator

Grknpkdzn · 24 Mayıs 2021

Değerli hocam.
Daha yeni deneme fırsatım oldu.
Konu ile alakalı olarak,
1-Talep No kısmında 3724 e ait 6 kalem girdi var. Bunları getiriyor sorunsuz. Ama 1 tane 3724 yazıyor. Kalemlerin adedince bu 3727 ü aşağıya doğru sıralayabilir miyiz?
2-Birim bilgilerini doğru çekiyor fakat miktar bilgilerini çekmiyor.
3-Misalen sorucam. Ben, 3724 yazsam hemen altına 3725 yazsam onunda hemen altına 3726 yazsam ve ondan sonra içeri aktar desem, ekteki hali ile listeleyebilme durumu olabilir mi?

Korhan Ayhan · 24 Mayıs 2021

Ben size senaryo nasıl olacak diye sormuştum....

Grknpkdzn · 24 Mayıs 2021

Grknpkdzn' Alıntı:
Korhan hocam şöyle,
Bahsettiğimiz sütunların dışındakilere farklı veriler elle giriliyor olacak.

"B" stütununa (Talep No) yazılması elzemdir.

Senaryo şöyle;
3725 yazdım. Hemen altına 3726 yı yazdım diyelim.
3725 için ilgili başlıklar altına yer alan 3 kalem bilgisini,
3726 için ilgili başlıklar altında yer alan 2 kalem bilgisini listeliyecek. Yani ben hangi sipariş numarasını istemişsem ilgili numarada kaç kalem bilgi varsa silinmeden ekleye ekleye devam edicem..

Korhan bey,
Senaryoyu şu açıklamada yapmıştım ama sanırım anlamayıp doğru ifade edemedim sanırım.

Korhan Ayhan · 24 Mayıs 2021

Miktar sütununda ki problem şu;

İlgili alana miktarı formülle getiriyorsunuz. Fakat formülde boş olan hücreler için "" (çift tırnak) ifadesi kullanmışsınız. Bu ifade metinsel bir ifadedir. Ama miktar sütunu aslında sayısal bir alandır. Aktarım işleminde ADO kullandığımız için işler karışıyor. Sizin tablolarınızda ADO kullanmamak gerekiyor. Çünkü standart bir veri girişi formatınız yok. Bu durum ADO için hep sorun çıkaracaktır.

Uygun olduğumda normal kodlama ile veri aktarımı için kodu yazar paylaşırım.

Korhan Ayhan · 25 Mayıs 2021

B sütununa talep no yazdıktan sonra yazdığınız hücreleri seçin ve butona tıklayın. Diğer dosyanızda uygun kayıtlar aktarılacaktır.

Dosyanız ADO kullanımına uygun olmadığı için klasik veri alma kodlarını kullandım.

Grknpkdzn · 25 Mayıs 2021

Korhan hocam ellerinize sağlık on numara beş yıldız çalışıyor.
Size bir sorum ve bir isteğim olacak,
Diğer dosya açık iken, içeri aktar tuşuna basınca dosyayı kapatıyor. Bu zorunlu değilse hangi kodu false etmem gerekir?
Birde vaktiniz müsait olunca,
geçen seferki gibi kod bloklarının nasıl işlediğine dair açıklama eklerseniz çok sevinirim..
Allah bin kere razı olsun.

Korhan Ayhan · 26 Mayıs 2021

Dosyanın kapanmaması için bu satırı silmelisiniz.

K2.Close 0

Korhan Ayhan · 26 Mayıs 2021

Yine satır aralarına kısa notlar düştüm.

C++:

Option Explicit

Private Sub CommandButton1_Click()
    Rem Bu bölümde makro içinde kullanacağımız değişkenleri tanımlıyoruz.
    Dim Dizi As Object, K1 As Workbook, S1 As Worksheet
    Dim K2 As Object, S2 As Object, Zaman As Double
    Dim Yol As String, Dosya As String, Sayfa_Adi As String
    Dim Son As Long, Satir As Long, Talep_No As Variant
    Dim Veri As Variant, X As Long, Say As Long
    
    Rem Ekran hareketlerini kapatıyoruz.
    Application.ScreenUpdating = False
    
    Rem İşlem süresini tespit edebilmek için bir zaman sayacı başlatıyoruz.
    Zaman = Timer
    
    Rem Çalışma kitabını ve işlem yapılacak sayfayı kısa isimle hafızaya alıyoruz. Benzersiz dizi tanımlaması için Dictionary nesnesini tanımlıyoruz.
    Set Dizi = CreateObject("Scripting.Dictionary")
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("Firma ve Fiyat Bilgileri ")
    
    Rem Seçilen hücrelerde ki talep numaralarını benzersiz olarak diziye yüklüyoruz.
    For Each Talep_No In Selection
        If Talep_No <> "" Then
            If Not Dizi.Exists(CStr(Talep_No)) Then
                Dizi.Add CStr(Talep_No), Nothing
            End If
        End If
    Next
    
    Rem Eğer seçilen hücrelerde talep numarası yoksa kullanıcıya talep numarası girmesi için bilgi veriyoruz ve işlemi sonlandırıyoruz.
    If Dizi.Count = 0 Then
        MsgBox "Lütfen talep numarası giriniz!", vbCritical
        Exit Sub
    End If
    
    Rem Veri alınacak çalışma kitabının yolunu, dosya adını ve sayfa adını tanımlıyoruz.
    Yol = K1.Path & Application.PathSeparator
    Dosya = "GELEN MALZEME TAKİP ÇİZELGESİ REVİZE.xlsx"
    Sayfa_Adi = "TALEP TAKİP FORMU"
                
    Rem Dosyanın belirtilen klasörde olup olmadığını kontrol ediyoruz.
    Dosya = Dir(Yol & Dosya)
    
    Rem Eğer dosya varsa veri alma işlemine başlıyoruz.
    If Dosya <> "" Then
        Rem Veri alınacak dosyayı gizli şekilde açıyoruz ve sayfa adını tanımlıyoruz.
        Set K2 = GetObject(Yol & Dosya)
        Set S2 = K2.Sheets(Sayfa_Adi)
        
        Rem Veri alınacak sayfadaki son dolu hücreyi tespit ediyoruz.
        Son = S2.Cells(S2.Rows.Count, 1).End(3).Row
        
        Rem Eğer sayfada tek satır varsa dizi tanımlaması sorun çıkaracağı için en az iki satır kapsayacak şekilde Son değerini tanımlıyoruz.
        If Son < 4 Then Son = 4
        
        Rem Alınacak verileri Veri isimli değişkene (diziye) yüklüyoruz.
        Veri = S2.Range("A3:Q" & Son).Value
        
        Rem Veri alınacak dosya ile işimiz kalmadığı için kapatıyoruz.
        K2.Close 0
        
        Rem Sizin tablonuza göre verilerin aktarılacağı sütunlar arasında ellenmemesi gereken sütunlar olduğu için parçalı veri aktarımını sağlamak adına 3 farklı dizi tanımlaması oluşturuyoruz.
        Rem Eğer aralarda ellenmemesi gereken sütun olmasaydı tek tanımlama bize yetecekti.
        ReDim Liste_1(1 To S1.Rows.Count, 1 To 2)
        ReDim Liste_2(1 To S1.Rows.Count, 1 To 1)
        ReDim Liste_3(1 To S1.Rows.Count, 1 To 2)
        
        Rem Benzersiz olarak diziye yüklediğimiz talep numaralarını döngüye alıyoruz.
        For Each Talep_No In Dizi.Keys
            Rem Eğer kontrol edilen talep numarası boş değilse işleme devam ediyoruz.
            If Talep_No <> "" Then
                Rem Kapalı dosyadaki hafızaya aldığımız verileri döngüye alıyoruz.
                For X = LBound(Veri, 1) To UBound(Veri, 1)
                    Rem Eğer sorguladığımız talep numarası ile kapalı dosyadaki hafızaya veri yığını içindeki talep numarası eşleşiyorsa işleme devam ediyoruz.
                    If CLng(Talep_No) = Veri(X, 1) Then
                        Rem Talep numaraları eşleşiyorsa tanımladığımız 3 farklı diziye eşleşen verileri yüklüyoruz.
                        Say = Say + 1
                        Liste_1(Say, 1) = Veri(X, 1)
                        Liste_1(Say, 2) = Veri(X, 12)
                        Liste_2(Say, 1) = Veri(X, 6)
                        Liste_3(Say, 1) = Veri(X, 11)
                        Liste_3(Say, 2) = Veri(X, 10)
                    End If
                Next
            End If
        Next
    End If
    Rem Döngüleri sonlandırıyoruz.
                            
    Rem Verileri sayfaya yazdırmak için C sütunundaki ilk boş satırı tespit ediyoruz.
    Satir = S1.Cells(S1.Rows.Count, "C").End(3).Row
    If Satir < 3 Then
        Satir = 3
    Else
        Satir = Satir + 1
    End If
    
    Rem Sorgulama sonucunda uygun veri tespit edildiyse bunlara ait dizileri sayfaya aktarıyoruz.
    If Say > 0 Then S1.Cells(Satir, 2).Resize(Say, 2) = Liste_1
    If Say > 0 Then S1.Cells(Satir, 6).Resize(Say, 1) = Liste_2
    If Say > 0 Then S1.Cells(Satir, 8).Resize(Say, 2) = Liste_3
    
    Rem Sayfadaki sütun genişliklerini aktarılan verilere göre otomatik ayarlıyoruz.
    S1.Columns.AutoFit
    
    Rem Makroda kullanmak üzere hafızaya aldığımız kısa isimleri hafızadan kaldırıyoruz.
    Set S1 = Nothing
    Set S2 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set Dizi = Nothing
    
    Rem Ekran hareketlerini açıyoruz.
    Application.ScreenUpdating = True
    
    Rem Kullanıcıya yapılan işlemle ilgili bilgilendirme mesajı veriyoruz.
    If Say > 0 Then
        MsgBox "Veri aktarımı tamamlanmıştır." & vbCr & vbCr & _
               "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    Else
        MsgBox "Uygun kayıt bulunamadı!", vbExclamation
    End If
End Sub

Grknpkdzn · 29 Mayıs 2021

Korhan hocam tekrar merhaba.
Kodlarınıza bakarak yapmaya başladım ama bilgim yetmiyor.
Ekteki Mesai Takip_2021 dosyasının "B" sütununda personeller var. Bu personellerin yapmış olduğu,
Resmi tatil Mesaisi (Sütun AI) ve Fazla Mesai (Sütun AJ) saatlerini,
Puantaj dosyasında "C" sütununda ki personellerin "CV" ve "CW" hücrelerine girmesini istiyorum.

Not: Mesai Takip çizelgesinde ki personel sayısı, Puantaj dosyasındaki personel sayısından fazla olabilmektedir.

Kullancı0642 · 2 Nisan 2022

Bu konuda yazılmıs asagidaki makroyu aynı belgede ve aynı sayfada D6:AQ11 - D12:AQ17 - D18:AQ23 hucre aralıklarına veri almak istiyorum. Ayni makrodan 3 adet ekledim ve calıstı. Ancak hangi makroyu tekrar calıstırırsam bir alttakinin verilerini siliyor... makroda temizlenecek ve veri getirilecek alanı nasıl belirleyebiliriz...

Sub Düğme1_Tıklat()
Dim conn As Object, rs As Object, yol As String, dosya
Range("H2:I" & Rows.Count).ClearContents
Set conn = CreateObject("Adodb.Connection")
Set rs = CreateObject("Adodb.Recordset")
ChDir (ThisWorkbook.Path)
dosya = Application.GetOpenFilename("Excel Dosyaları,xlsx", , "LÜTFEN DOSYAYI SEÇİNİZ")
conn.Open "Provider=microsoft.ace.oledb.12.0;data source=" & dosya & ";extended properties=""excel 12.0;hdr=yes"";"
rs.Open "Select [Başlık 1],[Başlık 2] from [Sayfa1$A1:F" & Rows.Count & "]", conn, 1, 1
If rs.RecordCount > 0 Then Range("H2").CopyFromRecordset rs
rs.Close: conn.Close
MsgBox "Aktarma yapıldı."
End Sub[/CODE]
[/QUOTE]

Kapalı dosyadan buton ile veri alma.

Haluk

𐱅𐰇𐰼𐰚

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Grknpkdzn

Grknpkdzn

Korhan Ayhan

Administrator

Grknpkdzn

Ekli dosyalar

Korhan Ayhan

Administrator

Grknpkdzn

Korhan Ayhan

Administrator

Ekli dosyalar

Grknpkdzn

Ekli dosyalar

Korhan Ayhan

Administrator

Grknpkdzn

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Ekli dosyalar

Grknpkdzn

Korhan Ayhan

Administrator

Korhan Ayhan

Administrator

Grknpkdzn

Ekli dosyalar

Kullancı0642