SORU ve CEVAPLAR (Yazılabilir) > Çözülen Excel, Vba, Makro, Formül vb. Soruları

[Çözüldü] Kapalı Excel Çalışma Kitaplarından Veri Çekmek

(1/2) > >>

drejan62:
Merhabalar,
c:\Belgelerim\Maaşlar Klasörü içinde
Maaş1, Maaş2, Maaş3, Maaş4, Maaş5 isimli dosyalarımız var.
Bu dosyalarda veriler 7. satırdan başlıyor ve satır sayısı değişken,
Amacım kodları yazdığım Çalışma kitabında Sayfa1'e bu maaşları alt alta kaydetmek. Yanlız ilk maaşı1 sayfasını 7. satırdan en son satıra kadar alacak sonraki maaş2,3,5 çalışma kitaplarını ise 8, satırdan son satıra kadar alarak alt alta kaydedecek.
ben alttaki kodları deniyorum ama zaman alıyor haliyle,
zaman kazanmak için kodları kısaltabilirmiyiz,
Teşekkürler


--- Kod: --- 
Workbooks.Open Filename:="C:\\Belgelerim\Maaşlar \Maaş1.xls"
   
    Range("C7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("TümMaaş.xls").Activate
    Sheets("Sayfa1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Selection.End(xlDown).Select
    Windows("Maaş1.xls").Activate
    ActiveWorkbook.Close False
   
Workbooks.Open Filename:="C:\\Belgelerim\Maaşlar \Maaş2.xls"

    Range("C8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("TümMaaş.xls").Activate
    Sheets("Sayfa1").Select
    ActiveCell.Offset(1, 0).PasteSpecial
    Application.CutCopyMode = False
    Range("A1").Select
    Selection.End(xlDown).Select
    Windows("Maaş2.xls").Activate
    ActiveWorkbook.Close False
--- Kod sonu ---
 

Orion1:

--- Alıntı yapılan: drejan62 - 19 Ağustos 2010, 11:09:20 ---Merhabalar,
c:\Belgelerim\Maaşlar Klasörü içinde
Maaş1, Maaş2, Maaş3, Maaş4, Maaş5 isimli dosyalarımız var.
Bu dosyalarda veriler 7. satırdan başlıyor ve satır sayısı değişken,
Amacım kodları yazdığım Çalışma kitabında Sayfa1'e bu maaşları alt alta kaydetmek. Yanlız ilk maaşı1 sayfasını 7. satırdan en son satıra kadar alacak sonraki maaş2,3,5 çalışma kitaplarını ise 8, satırdan son satıra kadar alarak alt alta kaydedecek.
ben alttaki kodları deniyorum ama zaman alıyor haliyle,
zaman kazanmak için kodları kısaltabilirmiyiz,
Teşekkürler


--- Kod: --- 
Workbooks.Open Filename:="C:\\Belgelerim\Maaşlar \Maaş1.xls"
   
    Range("C7").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("TümMaaş.xls").Activate
    Sheets("Sayfa1").Select
    Range("A1").Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("A1").Select
    Selection.End(xlDown).Select
    Windows("Maaş1.xls").Activate
    ActiveWorkbook.Close False
   
Workbooks.Open Filename:="C:\\Belgelerim\Maaşlar \Maaş2.xls"

    Range("C8").Select
    Range(Selection, Selection.End(xlToRight)).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Windows("TümMaaş.xls").Activate
    Sheets("Sayfa1").Select
    ActiveCell.Offset(1, 0).PasteSpecial
    Application.CutCopyMode = False
    Range("A1").Select
    Selection.End(xlDown).Select
    Windows("Maaş2.xls").Activate
    ActiveWorkbook.Close False
--- Kod sonu ---


--- Alıntı sonu ---
Örnek dosyaları eklerseniz bir şeyler yaparız.

drejan62:
Üstad,
Örnek dosya eklidim.
Teşekkür ederim.
Maaş1 ve Maaş2 dosyalırındaki veriler
Tümmaş dosyasındaki Sayfa1 e kopyalanacak.
sağolun

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

Orion1:
Dosyanız ektedir. :cooll

--- Kod: ---Sub aktar_59()
Dim i  As Byte, conn As Object, rs As Object, sat As Long
Dim dosya As String
Sheets("Sayfa1").Select
sat = 2
Range("A2:M65536").ClearContents
Application.ScreenUpdating = False
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
For i = 1 To 2
    dosya = "Maaş" & i & ".xls"
    If Dir(ThisWorkbook.Path & "\" & dosya) = "" Then
        MsgBox ThisWorkbook.Path & "\" & dosya & " Bulunamdı.", vbCritical, "UYARI"
        Else
        conn.Open "Provider=Microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & dosya & ";extended properties=""Excel 8.0;Hdr=no;imex=1"";"
        rs.Open "Select * from [Sayfa1$A8:M65536];", conn, 1, 1
        If rs.RecordCount > 0 Then
            Range("A" & sat).CopyFromRecordset rs
            sat = Cells(65536, "A").End(xlUp).Row + 1
        End If
        rs.Close: conn.Close
    End If
Next i
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
If Cells(65536, "A").End(xlUp).Row > 1 Then
    MsgBox "Veriler aktarıldı." & vbLf & _
    "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End If
End Sub
--- Kod sonu ---

[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]

drejan62:
Teşekkürler üstad.
Çok sağol

Navigasyon

[0] Mesajlar

[#] Sonraki Sayfa