Kapalı dosya kopyalama

[mbattal]

Arkadaşlar Merhaba,
Aynı klasör içindeki Kapalı durumda olan A dosyasından B dosyasına belirtilen kriterlerde veri kopyalamak istiyorum.
Detayları EK te belirttim.
Şimdiden herkeze çok teşekkür ederim

 

[asi_kral]

Merhaba
A dosyasında E sütunu devamlı böyle sıralı mı yoksa karışık mı giriş olacak mı_?

 

[mbattal]

Sayın asi kral,
Karışık giriş olacak..
Teşekkürler

 

[asi_kral]

Merhaba
Bu kodu b kitabında boş bir module kopyalayın ve deneyin.

Option Explicit
Sub bul_getir()
Dim XCL As Application, KTP As Workbook
Dim S1 As Worksheet, S2 As Worksheet, ÇLŞ As Variant
Dim STR As Variant, STR1 As Long, BUL As Range
Set S1 = ActiveSheet
Application.ScreenUpdating = False
ÇLŞ = ActiveCell.Address
S1.Range("A4:F" & Rows.Count).Clear
Set XCL = CreateObject("Excel.Application")
XCL.Visible = False
Set KTP = XCL.Workbooks.Open(ThisWorkbook.Path & "\A.xls")
Set S2 = KTP.Sheets("Sayfa1")
STR1 = S2.Range("A" & Rows.Count).End(xlUp).Row
Set BUL = S2.Range("E:E").Find(S1.Range("A2"), , , xlWhole)
If Not BUL Is Nothing Then
STR = BUL.Address
S2.Range(STR & ":H" & STR1).Copy
S1.Range("A4").PasteSpecial (xlPasteValues)
S2.Range("L" & BUL.Row & ":L" & STR1).Copy
S1.Range("E4").PasteSpecial (xlPasteValues)
S2.Range("O" & BUL.Row & ":O" & STR1).Copy
S1.Range("F4").PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
End If
XCL.Quit
Range(ÇLŞ).Select
Application.ScreenUpdating = True
End Sub

 

[mbattal]

Teşekkür ederim
Deneyeceğim.

 

[Orion1]

Ado ile alternatif.
dosya ektedir.

Sub kapali59()
Dim conn As Object, rs As Object
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
        ThisWorkbook.Path & "\A.xls;extended properties=""excel 8.0;imex=1;hdr=no"";")
rs.Open "select F1,F2,F3,F4,F8,F11 from [Sayfa1$E3:O65536] where F1=" & _
        Range("A2").Value & ";", conn, 1, 1
Application.ScreenUpdating = False
Range("A4:F65536").ClearContents
If rs.RecordCount > 0 Then Range("A4").CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com", _
        vbOKOnly + vbInformation, Application.UserName
End Sub

 

[EmrExcel16]

Sayın Orion1 hocam
Vermiş olduğunuz koda ilavaten sayfa1 den aldıkları değerlerden sonra sayfa2 de değer aldırabilirmiyiz .
Eğer aldırabilirsek aldıracağım değer sabit A3:C hücreleri aralığı sayfa1 den ne alırsa alsın sayfa2 den aldığı A3:C değerini sayfa1 den aldığı değerin altına eklemek istiyorum.
Yardımlarınız için teşekkür ederim

 

[Orion1]

Sayın Orion1 hocam
Vermiş olduğunuz koda ilavaten sayfa1 den aldıkları değerlerden sonra sayfa2 de değer aldırabilirmiyiz .
Eğer aldırabilirsek aldıracağım değer sabit A3:C hücreleri aralığı sayfa1 den ne alırsa alsın sayfa2 den aldığı A3:C değerini sayfa1 den aldığı değerin altına eklemek istiyorum.
Yardımlarınız için teşekkür ederim

Örnek dosya ekleyiniz.Dosya üzerindede açıklama yazınız.

 

[EmrExcel16]

Dosya ektedir
İyi çalışmalar..

 

[Orion1]

Dosya ektedir
İyi çalışmalar..

Dosyanız ektedir.

Sub kapali59()
Dim conn As Object, rs As Object
Set conn = CreateObject("Adodb.connection")
Set rs = CreateObject("Adodb.recordset")
conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & _
        ThisWorkbook.Path & "\A.xls;extended properties=""excel 8.0;imex=1;hdr=no"";")
rs.Open "select F1,F2,F3,F4,F8,F11 from [Sayfa1$E3:O65536] where F1=" & _
        Range("A2").Value & ";", conn, 1, 1
Application.ScreenUpdating = False
Range("A4:F65536").Clear
If rs.RecordCount > 0 Then Range("A4").CopyFromRecordset rs
rs.Close
sat = Cells(65536, "A").End(xlUp).Row + 2
Cells(sat, "B").Value = "FİRMA ADI"
Cells(sat, "C").Value = "NO"
Cells(sat, "D").Value = "NOT"
Range("B" & sat & ":D" & sat).Font.Color = vbRed
Range("B" & sat & ":D" & sat).Font.Bold = True
Range("B" & sat & ":D" & sat).Font.Size = 8
rs.Open "select * from [Sayfa2$A3:C65536];", conn, 1, 1
If rs.RecordCount > 0 Then Range("B" & sat + 1).CopyFromRecordset rs
rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing

Application.ScreenUpdating = True
MsgBox "Veriler aktarıldı." & vbLf & "evrengizlen@hotmail.com", _
        vbOKOnly + vbInformation, Application.UserName
End Sub

 

[EmrExcel16]

Hocam teşekkür ederim
Kolay gelsin