Merhabalar.
Aşağıdaki kod ile kapalı dosyalara veri aktarıyorum.
Kod sayın dentex arkadaşımıza aittir. Bir kez daha teşekkür ediyorum kendisine.
Veri aktarırken "Ocak" adlı sayfa ile kapalı dosyalardaki "liste" adlı sayfaların E ve F sütunlarında ki
değerler karşılaştırılıyor. Eşleşme sağlandığında ilgili veriler aktarılıyor.
Benim sizlerden istirhamım.
E ve F sütununu değilde D ve F sütununu karşılaştırarak verileri aktarmak.
Birde kırmızı ile belirttim kısmı; G H I vs diye istediğim şekilde düzenleyebilmek.
Gerekirse örnek dosyada ekleyebilirm.
Yardımlarınızı bekliyorum teşekkür ederim.
Aşağıdaki kod ile kapalı dosyalara veri aktarıyorum.
Kod sayın dentex arkadaşımıza aittir. Bir kez daha teşekkür ediyorum kendisine.
Veri aktarırken "Ocak" adlı sayfa ile kapalı dosyalardaki "liste" adlı sayfaların E ve F sütunlarında ki
değerler karşılaştırılıyor. Eşleşme sağlandığında ilgili veriler aktarılıyor.
Benim sizlerden istirhamım.
E ve F sütununu değilde D ve F sütununu karşılaştırarak verileri aktarmak.
Birde kırmızı ile belirttim kısmı; G H I vs diye istediğim şekilde düzenleyebilmek.
Gerekirse örnek dosyada ekleyebilirm.
Yardımlarınızı bekliyorum teşekkür ederim.
Dim sonuc As Boolean
Dim dosya As String
Dim i As Long
Sub sd()
Dim sy As Worksheet
Set sy = ThisWorkbook.Worksheets("Ocak")
sn = sy.[e65536].End(3).Row
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
With fDialog
'Çoklu seçim
.AllowMultiSelect = True
.InitialFileName = strInitPath
'Dialog box başlığı
.Title = "Lütfen ilgili dosyaları seçin!"
.Filters.Clear
.Filters.Add "XLS or XLSX Files", "*.xls, *.xlsx"
If .Show = True Then
For Each varfile In .SelectedItems
For i = 4 To sn
sonuc = False
Call yaz(varfile, Trim(sy.Cells(i, "e")), Trim(sy.Cells(i, "f")), i)
If sonuc = True Then sy.Cells(i, "t") = "gönderildi"
Next i
Next
Else
MsgBox "Dosya seçmediniz!"
Exit Sub
End If
End With
End Sub
Public Function econn(dosya) As ADODB.Connection
Dim conn As New ADODB.Connection
exc_conn = "provider=microsoft.jet.oledb.4.0;data source=" & dosya & _
";extended properties=""excel 8.0;hdr=yes"""
On Error GoTo ErrorHandler
conn.ConnectionString = exc_conn
conn.Open
Set econn = conn
Exit Function
ErrorHandler:
MsgBox "Excel Veritabanına Bağlanamadı!"
Resume Next
End Function
Sub yaz(dosya, e, f, sat As Long)
Dim sh As Worksheet
Dim sh1 As Worksheet
Dim Kat As Object
Dim rs As Object
sy_var = 0
Set sh1 = ThisWorkbook.Worksheets("Ocak")
'Set sh = dosya
Set rs = New ADODB.Recordset
'son = sh.[e65536].End(3).Row 'ad soyad sütunu
Set conn = econn(dosya)
'conn.CursorLocation = adUseServer
Set Kat = CreateObject("adox.catalog")
Set tbl = CreateObject("adox.table")
Kat.ActiveConnection = conn
For Each tbl In Kat.Tables
If tbl.Name = "liste$" Then sy_var = 1 'liste sayfası yoksa
Next tbl
If sy_var = 0 Then GoTo alt
SQLStr = "select * from [liste$] where trim([Adı Soyadı])='" & e & "' and trim([Köy-Kasaba])='" & f & "'"
' rs.Open SQLStr, conn, CursorTypeEnum.adOpenDynamic, LockTypeEnum.adLockOptimistic, CommandTypeEnum.adCmdText
rs.Open SQLStr, conn, adOpenStatic, adLockOptimistic, adCmdText
If rs.EOF = True Or rs.BOF Then GoTo alt
sonuc = True
For sut = 13 To 19 'data sütunları
If IsEmpty(sh1.Cells(sat, sut)) = False And IsNull(rs.Fields(sut - 1)) = True Then
rs.Fields(sut - 1).Value = sh1.Cells(sat, sut)
rs.Fields(0).Value = Space(5) & "fed"
rs.Update
End If
Next sut
rs.Close: conn.Close
alt:
Set rs = Nothing: Set conn = Nothing
Set sh = Nothing
Set sh1 = Nothing
Set Kat = Nothing
Set tbl = Nothing
End Sub
Son düzenleme: