Excel Vba Forum - Excelce.Net
SORU ve CEVAPLAR (Yazılabilir) => Microsoft Excel, Vba, Makro, Formül vb. Soruları => Çözülen Excel, Vba, Makro, Formül vb. Soruları => Konuyu başlatan: 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
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
-
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
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
Örnek dosyaları eklerseniz bir şeyler yaparız.
-
Ü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.]
-
Dosyanız ektedir. :cooll
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
[Forum yazılım güncelleme esnasında sorun oluştuğundan eklendi silinmiştir.]
-
Teşekkürler üstad.
Çok sağol
-
Rica ederim.
İyi çalışmalar. :cooll
-
Sayın Evren Gizlen;
Günaydın..
Bu güzel katkınızı içeren dosyayı arşivliyorum. Teşekkürler...
-
merhaba,
Ben belirttiğiniz metodu kullanarak verileri çektim. Bu sebepten dolayı çok teşekkürler. Ancak saatler "10:21:06 ÖÖ" veya "11:48:15 ÖS" şeklinde geliyor. Sayı biçiminden "23:48:15" yapmak istiyorum ancak değişmiyor. Yardımcı olabilirseniz çok sevinirim. Şimdiden teşekkürler