• DİKKAT

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

kapalı dosya

igultekin2000

igultekin2000

Katılım
5 Eylül 2007
Mesajlar
1,247
Excel Vers. ve Dili
ofis 2010
iyi günler, kumas ve emtia olarak iki ayrı rapor dosyam oluşuyor. iki ayrı dosyası birleştirmek istiyorum. kapalı dosyadan veri alma örneklerine baktım ama biraz karışık geldi.
Q7Ag83.jpg
[/url][/IMG]
 

Ekli dosyalar

Merhaba,

Rapor dosyasında yer alan ürün cinsleri hep sabit mi yoksa değişlen mi?

Bilgilerinizi rica ederim.

İyi çalışmalar.
 
bu kod revizyon olur mu

igultekin2000' Alıntı:
iyi günler, kumas ve emtia olarak iki ayrı rapor dosyam oluşuyor. iki ayrı dosyası birleştirmek istiyorum. kapalı dosyadan veri alma örneklerine baktım ama biraz karışık geldi.
Q7Ag83.jpg
[/url][/IMG]
Genişletmek için tıkla ...

Kod: 
Sub KOD2()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
sonsat = Cells(Rows.Count, "A").End(xlUp).Row + 1
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
        ThisWorkbook.Path & "\kapalı1.xlsm;extended properties=""excel 12.0;hdr=no;imex1"""
rs.Open "select * from [Sayfa1$];", conn, 1, 3
Application.ScreenUpdating = False
If rs.RecordCount > 0 Then Range("A" & sonsat).CopyFromRecordset rs
Application.ScreenUpdating = True
rs.Close
conn.Close
Set rs = Nothing: Set conn = Nothing
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com"
End Sub
işime yarayacak bir kod buldum ama ufak bir revizyona ihtiyacı var. KAPALI1 dosyasının B-C-D-E sütunlarında veri var, bu verileri Açık Dosyanın B-D-E-F hücrelerne aktaracak. yani açık dosyanın C hücresi atlanacak.
 
Merhaba
Emtıa ve kumas ayrı bir klasöre koyup denermisiniz
Kod: 
Sub numan()
 Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim satır As Long, Dosya As Object, Kaynak_Dosya As Object, SAYFA, SAYFA1 As Worksheet
    On Error GoTo Son
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    Range("C3:E" & Rows.Count).NumberFormat = "#,##0.00"
    Range("A3:E" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
    Dosya_Yolu = Klasör.Items.Item.Path
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
     If Dosya.Name = "KUMAS.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA1 = Kaynak_Dosya.Sheets("StokRapor")
 For Each SAYFA1 In Kaynak_Dosya.Worksheets
        satır1 = 3
       For x = 4 To SAYFA1.[B65536].End(3).Row
            SR.Range("A" & satır1) = SAYFA1.Range("B" & x)
            SR.Range("C" & satır1) = SAYFA1.Range("C" & x)
            SR.Range("D" & satır1) = SAYFA1.Range("D" & x)
             SR.Range("E" & satır1) = SAYFA1.Range("E" & x)
            
            satır1 = satır1 + 1
         
            Next x
            Next
            Kaynak_Dosya.Close True
        End If
        If Dosya.Name = "EMTIA.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA = Kaynak_Dosya.Sheets("STOK_BAKIYE")
 For Each SAYFA In Kaynak_Dosya.Worksheets
            satır = 3
       For k = 3 To SAYFA.[B65536].End(3).Row
            SR.Range("AA" & satır) = SAYFA.Range("B" & k)
            SR.Range("AB" & satır) = SAYFA.Range("C" & k)
            SR.Range("AC" & satır) = SAYFA.Range("D" & k)
            SR.Range("AD" & satır) = SAYFA.Range("E" & k)
            SR.Range("AE" & satır) = SAYFA.Range("F" & k)
            satır = satır + 1
            Next k
            Next
            Kaynak_Dosya.Close True
        End If
        
      
    Next
Son = Range("AA" & Rows.Count).End(3).Row
Alan = "AA3:AF" & Son
Range(Alan).Copy
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
 Range("AA3:AE" & Rows.Count).ClearContents
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", , "numan Şamil" ', vbInformation
    Exit Sub
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
 
Son düzenleme:
Sorunsuz çalışıyor

numan şamil' Alıntı:
Merhaba
Emtıa ve kumas ayrı bir klasöre koyup denermisiniz
Kod: 
Sub numan()
 Dim Klasör As Object, Veri_Dosyası As Workbook, SR As Worksheet, Dosya_Yolu As String
    Dim satır As Long, Dosya As Object, Kaynak_Dosya As Object, SAYFA, SAYFA1 As Worksheet
    On Error GoTo Son
    Set Klasör = CreateObject("Shell.Application").BrowseForFolder(0, "Lütfen bir klasor seçin !", 1)
    If Klasör Is Nothing Then
        MsgBox "Klasör seçimi yapmadığınız için işlemini iptal edilmiştir.", vbCritical
        Exit Sub
    End If
    Range("C3:E" & Rows.Count).NumberFormat = "#,##0.00"
    Range("A3:E" & Rows.Count).ClearContents
    Application.ScreenUpdating = False
    Set Veri_Dosyası = ThisWorkbook
    Set SR = Veri_Dosyası.Sheets("Sayfa1")
    Dosya_Yolu = Klasör.Items.Item.Path
    If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
    For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
    
     If Dosya.Name = "KUMAS.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA1 = Kaynak_Dosya.Sheets("StokRapor")
 For Each SAYFA1 In Kaynak_Dosya.Worksheets
        satır1 = 3
       For x = 4 To SAYFA1.[B65536].End(3).Row
            SR.Range("A" & satır1) = SAYFA1.Range("B" & x)
            SR.Range("C" & satır1) = SAYFA1.Range("C" & x)
            SR.Range("D" & satır1) = SAYFA1.Range("D" & x)
             SR.Range("E" & satır1) = SAYFA1.Range("E" & x)
            
            satır1 = satır1 + 1
         
            Next x
            Next
            Kaynak_Dosya.Close True
        End If
        If Dosya.Name = "EMTIA.xlsx" Then
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
 'Set SAYFA = Kaynak_Dosya.Sheets("STOK_BAKIYE")
 For Each SAYFA In Kaynak_Dosya.Worksheets
            satır = 3
       For k = 3 To SAYFA.[B65536].End(3).Row
            SR.Range("AA" & satır) = SAYFA.Range("B" & k)
            SR.Range("AB" & satır) = SAYFA.Range("C" & k)
            SR.Range("AC" & satır) = SAYFA.Range("D" & k)
            SR.Range("AD" & satır) = SAYFA.Range("E" & k)
            SR.Range("AE" & satır) = SAYFA.Range("F" & k)
            satır = satır + 1
            Next k
            Next
            Kaynak_Dosya.Close True
        End If
        
      
    Next
Son = Range("AA" & Rows.Count).End(3).Row
Alan = "AA3:AF" & Son
Range(Alan).Copy
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlValues
Application.CutCopyMode = False
 Range("AA3:AE" & Rows.Count).ClearContents
    Application.ScreenUpdating = True
   
    MsgBox "İşleminiz tamamlanmıştır.", , "numan Şamil" ', vbInformation
    Exit Sub
Son:
    Kaynak_Dosya.Close True
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub
Genişletmek için tıkla ...

elinize sağlık, kodlar sorunsuz çalışıyor.
 
İyi çalışmalar
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst