Soru Klasör Altındaki Dosyaların E Kolununda dolu olan verileri kopyalamak

bulentkars · 15 Nisan 2022

Arkadaşlar Merhaba,

C:\TALIMATLAR\YEDEK\ Klasörü altında birleştirilecek dosya örneği gibi

aynı formatta 1 den fazla çalışma kitabım var, burada yapmak istediğim.

Sayfaları birleştir yaptığımda ilgili klasör altındaki dosyaları tek tek açacak

her çalışma kitabında 3 adet sayfa var, Grup,329,320 sayfaların E kolonunda

dolu olan satırları seçip ekteki örnekteki gibi yapıştıracak. Yapıştırma işlemini yaptıktan sonra

F kolonuna hangi sayfadan verilerin geldiğini sayfa adını yazmasını istiyorum.

Yardımcı olabilirseniz sevinirim. Örnek Dosya Ekte Şimdiden Teşekkürler

Ömer · 16 Nisan 2022

Merhaba,

Deneyiniz.

Kod:

Sub Dosyalardan_Veri_Al()

    Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet
    
    ThisWorkbook.Activate

    Set S1 = Sheets("Log")
    
    yol = "C:\TALIMATLAR\YEDEK\"
    Dosya = Dir(yol & "\*.xls*")
    Sayfa = Array("Grup", "320", "329")
    
    Application.ScreenUpdating = False
    S1.Range("A2:F" & Rows.Count).ClearContents 'eğer eski veriler silinmeyecekse bu satırı silersiniz.
    sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
    
    Do While Dosya <> ""
        
        Workbooks.Open yol & Dosya
        For i = 0 To UBound(Sayfa)
            With Sheets(Sayfa(i))
                son = .Cells(Rows.Count, "E").End(xlUp).Row
                .Range("A1:E" & son).AutoFilter Field:=5, Criteria1:="<>"
                .Range("A2:E" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
                a = sat
                sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
                S1.Cells(a, "F").Resize(sat - a, 1) = .Name
            End With
        Next i
        
        Workbooks(Dosya).Close False
        Dosya = Dir

    Loop
    
    S1.Columns("F:F").HorizontalAlignment = xlLeft
    Application.ScreenUpdating = True
  
    MsgBox "İşleminiz Bitti.", vbInformation
    
End Sub

bulentkars · 16 Nisan 2022

Ömer Bey,

Çok Çok Teşekkür ederim. tam istediğim gibi olmuş.. sadece benim orjininal dosyamda hem açılışta hem de sayfalarda koruma var,

1 -Açılıştaki Sayfa Korumasını "123" makro içirisine girebilirmiyiz.
2 -Sayfalarda Koruma Olduğu için " .Range("A1:E" & son).AutoFilter Field:=5, Criteria1:="<>" " satırda hata veriyor. Koruma "123" kaldırılırılıp yapılırsa daha iyi olur.
3- Makro Çalıştığında Log sayfasına bağlı kalmassın, bunu eklentiye koyacağım için makro çalıştırdığımda yeni sayfa oluşturup, il sayfdan başlıkları alsın istiyorum.
Teşekkürler

Ömer · 16 Nisan 2022

3. sorunuzu anlayamadım. Daha detaylı açıklama yapınız.
Diğer 2 sorunuz için:

Kod:

Sub Dosyalardan_Veri_Al()

    Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet
  
    ThisWorkbook.Activate

    Set S1 = Sheets("Log")
  
    yol = "C:\TALIMATLAR\YEDEK\"
    Dosya = Dir(yol & "\*.xls*")
    Sayfa = Array("Grup", "320", "329")
  
    Application.ScreenUpdating = False
    S1.Range("A2:F" & Rows.Count).ClearContents 'eğer eski veriler silinmeyecekse bu satırı silersiniz.
    sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
  
    Do While Dosya <> ""
      
        Workbooks.Open Filename:=yol & Dosya, Password:="123"
        For i = 0 To UBound(Sayfa)
            With Sheets(Sayfa(i))
                .Unprotect "123"
                son = .Cells(Rows.Count, "E").End(xlUp).Row
                .Range("A1:E" & son).AutoFilter Field:=5, Criteria1:="<>"
                .Range("A2:E" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
                a = sat
                sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
                S1.Cells(a, "F").Resize(sat - a, 1) = .Name
                .Protect "123"
            End With
        Next i
      
        Workbooks(Dosya).Close False
        Dosya = Dir

    Loop
  
    S1.Columns("F:F").HorizontalAlignment = xlLeft
    Application.ScreenUpdating = True

    MsgBox "İşleminiz Bitti.", vbInformation
  
End Sub

Ömer · 16 Nisan 2022

Sanırım yeni sayfa için istediğiniz bu.

Kod:

Sub Dosyalardan_Veri_Al()

    Dim yol As String, Dosya As String, Sayfa(), sat As Long, i As Byte, a As Long, son As Long, S1 As Worksheet
   
    ThisWorkbook.Activate
    Sheets.Add After:=ActiveSheet

    Set S1 = ActiveSheet
   
    yol = "C:\TALIMATLAR\YEDEK\"
    Dosya = Dir(yol & "\*.xls*")
    Sayfa = Array("Grup", "320", "329")
   
    Application.ScreenUpdating = False
    S1.Range("A2:F" & Rows.Count).ClearContents 'eğer eski veriler silinmeyecekse bu satırı silersiniz.
    sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
   
    Do While Dosya <> ""
       
        Workbooks.Open Filename:=yol & Dosya, Password:="123"
        For i = 0 To UBound(Sayfa)
            With Sheets(Sayfa(i))
                .Unprotect "123"
                If S1.Range("A1") = "" Then
                    .Range("A1:E1").Copy S1.Range("A1")
                    S1.Range("A1").Copy S1.Range("F1")
                    S1.Range("F1") = "Sayfa Adı"
                End If
                son = .Cells(Rows.Count, "E").End(xlUp).Row
                If son > 1 Then
                    .Range("A1:E" & son).AutoFilter Field:=5, Criteria1:="<>"
                    .Range("A2:E" & son).SpecialCells(xlCellTypeVisible).Copy S1.Cells(sat, "A")
                    a = sat
                    sat = S1.Cells(Rows.Count, "E").End(xlUp).Row + 1
                    S1.Cells(a, "F").Resize(sat - a, 1) = .Name
                End If
                .Protect "123"
            End With
        Next i
       
        Workbooks(Dosya).Close False
        Dosya = Dir

    Loop
   
    S1.Columns("F:F").HorizontalAlignment = xlLeft
    S1.Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True

    MsgBox "İşleminiz Bitti.", vbInformation
   
End Sub

bulentkars · 16 Nisan 2022

Ömer Bey,

3. Soru : Yaptığınız makroyu sadece sayfa adı LOG olan bir sayfada çalışıyor. Ben makroyu çalıştırdığımda aktif sayfada veya yeni bir sayfa oluşturup işlem yapsın istiyorum,

1- Son ilavede korumalar tamam olmuş sadece dosyaları birleştirirken her dosya için ayrı başlık yazıyor, örneğin 5 dosya birleştirmesi yaparken 5 başlık oluyor, bunu tek başlık yapabilirsek sevinirim.

Ömer · 16 Nisan 2022

3. sorunuzun cevabını #5. mesajda verdim.
Eklediğiniz örneklere göre bende tek başlık yazdı. Fazla başlık yazan dosya örneği eklerseniz deneyebilirim.

Ömer · 16 Nisan 2022

bulentkars' Alıntı:
Son ilavede korumalar tamam olmuş sadece dosyaları birleştirirken her dosya için ayrı başlık yazıyor, örneğin 5 dosya birleştirmesi yaparken 5 başlık oluyor, bunu tek başlık yapabilirsek sevinirim.

#5 numaralı mesajı güncelledim. Tekrar deneyiniz.

bulentkars · 16 Nisan 2022

Dosya Ekte,

Dosyayı çoğaltıp çalıştırdığınızda başlıklarda çoğalıyor.

bulentkars · 16 Nisan 2022

Ömer Bey,
Sorunu buldum, birleştirdiği sayfalarda Örneğin Grup sayfası E kolonu boş ise yani veri yoksa başlık koyuyor, sayflarda süz işlemi yapacak veri yoksa işlem yapmayacak, veri varsa kopyalama yaparsa düzelecek. Düzeltmeyi yapabilirseniz sevinirim.

Ömer · 16 Nisan 2022

#8 numaralı mesajda düzelttiğimi belirtmiştim.. #5 numaralı mesajı yeniden kopyalayıp deneyiniz.

bulentkars · 16 Nisan 2022

Ömer Bey Size Ne kadar teşekkür etsem azdır allah razı olsun çok teşekkür ederim.
Açılış parolası ile ilgili 2 kodum var bunları açtığımda bu kotta yaptığınız gibi korumayı nasıl açabilirim koda ilave yaparsanız çok sevinirim. Lütfen kusura bakmayın.

Kod:

'1.makro Kapalı Dosyadan veri alıyorum, çalışma kitabı açılışında şifre olduğu zaman veri gelmiyor şifre "123" makro ile çalışmasını istiyorum,
Private Sub UserForm_Initialize()
    Set ADODB_DATA = CreateObject("ADODB.Connection")
    
    
    
    DOSYA_YOLU = "Provider=Microsoft.ace.OLEDB.12.0;Data Source=" & "C:\TALIMATLAR\ARACLAR\Hesaplar.xlsm" & ";Extended Properties=""Excel 8.0;HDR=no;IMEX=1"";"
    
    
    ADODB_DATA.Open DOSYA_YOLU

    

      

Dim sorgu As String
sorgu = "Select * From [" & ActiveSheet.Name & "$A2:D65536]"
SQL_SORGUSU = sorgu

    
    
      
    Set KAYIT_SETİ = ADODB_DATA.Execute(SQL_SORGUSU)
    
    ListBox1.ColumnCount = 4
    ListBox1.ColumnWidths = "265;80;125;70"
      '  ListBox1.ColumnWidths = "283;68;125;70"
    ListBox1.Column = KAYIT_SETİ.GetRows
    ActiveSheet.Protect "24062003", AllowFiltering:=True 'koy
End Sub

Kod:

2.makro Açılıştaki Sayfa Korumasını "123" makro içirisine girebilirmiyiz.

Sub Kapali_Dosyayi_Kosula_Gore_Ac()

    Dim Yol As String, Dosya_Adi As String, Sayfa_Adi As String
    Dim Hedef_Yol As String, WB As Workbook, Kosul As Variant
    On Error Resume Next
    klasör_ara
  
    
    Yol = "O:\Ortak\TALIMATLAR\ARACLAR\"
    Dosya_Adi = "Hesaplar.xlsm"
    Sayfa_Adi = "329"
    Hedef_Yol = "C:\TALIMATLAR\ARACLAR\Hesap\"
  
  
  

    If Dir(Yol & Dosya_Adi) <> "" Then
        Kosul = ExecuteExcel4Macro("'" & Yol & "[" & Dosya_Adi & "]" & Sayfa_Adi & "'!R1C6")
     On Error Resume Next
        If UCase(Kosul) = "AÇ" Then
            If Dir(Hedef_Yol) = "" Then MkDir Hedef_Yol
        
            
            On Error Resume Next
            Set WB = Application.Workbooks.Item(Dosya_Adi)
              
            On Error GoTo 0
            If Not WB Is Nothing Then WB.Close True
          
            FileCopy Yol & Dosya_Adi, Hedef_Yol & Dosya_Adi
                      
            
                        
            
            
             Dim cevap
cevap = MsgBox("DiKKAT ..! Banka HESAPLAR Dosyasında İBAN'da müdahale var. Kontrol Ediniz.. Devam etmek istiyor musunuz..?", vbYesNo + vbCritical, "UYARI...")
If cevap = vbYes Then


 
            Workbooks.Open Hedef_Yol & Dosya_Adi
          
              
        End If
        
 End If
          
              
          
      
    Else
        MsgBox "Dosya bulunamadı!", vbExclamation, Application.UserName
    End If
End Sub

Ömer · 16 Nisan 2022

2. kodlarda,

Workbooks.Open Hedef_Yol & Dosya_Adi

yukarıdaki satırı aşağıdakiyle değiştirip deneyin.

Workbooks.Open Filename:=Hedef_Yol & Dosya_Adi, Password:="123"

.
.
.

1. kodlarda ise Ado yöntemi kullanılmış. Bildiğim kadarıyla bu yöntem direk şifreli dosyalarda çalışmıyor. Dolaylı olarak yine dosyayı açmak gerekir.- Örnek eklerseniz üzerinde çalışabilirim.

bulentkars · 16 Nisan 2022

Merhaba,

dosyayı açarken Workbooks.Open Filename:=Hedef_Yol & Dosya_Adi, Password:="123" tamam açtı,
ama içini açarken yukarıda şifreyi girmek lazım. aşağıdaki kodların olduğu yerede girmek lazım, bunud ayaparsanız iyi olur.
If Dir(Yol & Dosya_Adi) <> "" Then
Kosul = ExecuteExcel4Macro("'" & Yol & "[" & Dosya_Adi & "]" & Sayfa_Adi & "'!R1C6")

Ömer · 16 Nisan 2022

Verdiğim kodu If Dir(Yol & Dosya_Adi) <> "" Then satırından sonra ekleyerek deneyin.

bulentkars · 16 Nisan 2022

Ömer Bey,

Dosyanın açılmasını istemiyorum, dosya zaten en sonda açılıyor, kod arka planda hesaplarım.xlsm dosyasını açıyor F1 i kontrol ediyor eğer AÇ yazılı ise uayrı veriyor, bu işelemi yaparken dosya arka planda açılıyor, ben bu şekilde dosyanın açıldığını görmek istemiyorum, sorguyu yapmadan önce açılış parolasını girmek istiyorum. Teşekkürler

Ömer · 16 Nisan 2022

Deneme yapmadım.

If Dir(Yol & Dosya_Adi) <> "" Then

satırından sonra aşağıdaki satırı ilave ederek deneyin.

SendKeys "123" & "{Enter}"

.

bulentkars · 16 Nisan 2022

Excel kapanıyor ve pasword şifre açılıyor..

Ömer · 16 Nisan 2022

Yani sorun çözüldü sanırım.

bulentkars · 16 Nisan 2022

yok sorun çözülmedi, şifre istiyor

Soru Klasör Altındaki Dosyaların E Kolununda dolu olan verileri kopyalamak

bulentkars

Ekli dosyalar

Ömer

Moderatör

bulentkars

Ömer

Moderatör

Ömer

Moderatör

bulentkars

Ömer

Moderatör

Ömer

Moderatör

bulentkars

Ekli dosyalar

bulentkars

Ömer

Moderatör

bulentkars

Ömer

Moderatör

bulentkars

Ömer

Moderatör

bulentkars

Ömer

Moderatör

bulentkars

Ömer

Moderatör

bulentkars