Makro kodunda güncelleme

[igultekin2000]

iyi günler;
verileri seçerek başka sayfaya aktarırken güncellemeye ihtiyaç duydum, kullandığım makroda nasıl bir düzenlemem yapmam gerekiyor.
ANA çalışma sayfasındaki C sütununa göre verileri başka sayfaya aktarıyorum. Farklı seri numaraları olduğu için seçenek olarak C sütunundaki İLK ÜÇ karaktere göre verileri aktarmak istiyorum. Şöyle ki ; C sütunundaki ilk üç karakter ESGxxxxxxxxx ise, ESNxxxxxxxx durumuna göre ilgili satırları ESN ve ESG çalışma sayfalarına aktaracak, şekilde bir düzenlemeye ihtiyacım vardı, teşekkürler.

Sub aktar_ana()

Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
Application.EnableEvents = False
On Error Resume Next
Set sl = Sheets("ANA"): Set sk = Sheets("Tarih Sıralamalı Kesilen Fatura")
Son = sl.Range("A" & Rows.Count).End(3).Row + 1
sat = 2
sl.Range("A2:Q" & Son).ClearContents
For i = 2 To sk.Range("C" & Rows.Count).End(3).Row
If sk.Cells(i, "C") > "" Then
'If (sk.Cells(i, "C")) = "Normal" And Val(sk.Cells(i, "h")) > 0 Then
'Else
sl.Cells(sat, "A") = sk.Cells(i, "A")
sl.Cells(sat, "B") = sk.Cells(i, "C")
sl.Cells(sat, "D") = sk.Cells(i, "E")
sl.Cells(sat, "E") = sk.Cells(i, "G")
sl.Cells(sat, "F") = sk.Cells(i, "K")
sl.Cells(sat, "G") = sk.Cells(i, "M")
sl.Cells(sat, "H") = sk.Cells(i, "N")
sl.Cells(sat, "I") = sk.Cells(i, "P")


sat = sat + 1
End If

Next i
    Sheets("ANA").Select
    Sheets("ANA").Range("A2:I" & Range("I65656").End(3).Row).Font.Name = "Calibri" 'yazı fontu
    Sheets("ANA").Select
    Sheets("ANA").Range("A2:I" & Range("I65656").End(3).Row).Font.Size = 11 'yazı tipi boyutu
    Sheets("ANA").Select
    Sheets("ANA").Range("F2:H" & Range("H65656").End(3).Row).NumberFormat = "#,##0.00"
    Application.EnableEvents = False
    Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic

End Sub

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Verileri_Aktar()
    Dim Baglanti As Object, Kayit_Seti As Object
    Dim Dosya As String, Sorgu As String
    Dim S1 As Worksheet, S2 As Worksheet, Zaman As Double
    
    Zaman = Timer
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    Set S1 = Sheets("ESN")
    Set S2 = Sheets("ESG")
        
    Dosya = ThisWorkbook.FullName
        
    S1.Range("A2:I" & S1.Rows.Count).Clear
    S2.Range("A2:I" & S2.Rows.Count).Clear
    
    Baglanti.Open "Provider=Microsoft.Ace.OleDb.12.0;Data Source=" & _
    Dosya & ";Extended Properties=""Excel 12.0;Hdr=No"""
            
    Sorgu = "Select F1,F2,F3,F4,F5,F6,F7,F8,F9 From [ANA$A2:I] Where Left(F3,3) = 'ESN'"
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    If Kayit_Seti.RecordCount > 0 Then
        S1.Cells(S1.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
        S1.Columns.AutoFit
    End If
        
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    
    Sorgu = "Select F1,F2,F3,F4,F5,F6,F7,F8,F9 From [ANA$A2:I] Where Left(F3,3) = 'ESG'"
    Kayit_Seti.Open Sorgu, Baglanti, 1, 1
    If Kayit_Seti.RecordCount > 0 Then
        S2.Cells(S2.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
        S2.Columns.AutoFit
    End If
    
    If Kayit_Seti.State <> 0 Then Kayit_Seti.Close
    If Baglanti.State <> 0 Then Baglanti.Close
    
    MsgBox "Veri aktarımı tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    Set S1 = Nothing
    Set S2 = Nothing
End Sub