kod düzenleme yardımı

[spacebar]

değerli üstadlarım. aşağıdaki kodlar işimi görüyor ancak satır sayısı çok olduğu için excel boyutunu artırıyor. bu yüzden düzenleme yapmam gerekiyor.
Yapmak istediğim: kayıt aktarımını yaparken A ve C sutunu verileri geldikten sonra E ve G sutunu verilerinin gelmesi. yani kodlarımda E ve G sutunu verileri 10031. satırdan itibaren geliyordu. yapmak istenilen A-C nin bittiği satırdan itibaren gelmesi. yardımlarınız için şimdiden teşekkürler...

Sub kayitaktar()
ActiveSheet.Unprotect "karzarar.org "
Set s1 = Sheets("Data")
Set s2 = Sheets("Muhasebe Kaydı")

son = s1.Cells(Rows.Count, "A").End(3).Row
'eski = s2.Cells(Rows.Count, "A").End(3).Row

'If eski > 1 Then
s2.Range("A31:G20030" & eski).ClearContents

Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""

sorgu = "select [SK Muh Kodu] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[A31].CopyFromRecordset RS

sorgu = "select [Fark Aktif Değeri] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[C31].CopyFromRecordset RS


sorgu = "select [Amortisman Muh Kodu] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[E10031].CopyFromRecordset RS

sorgu = "select [Fark Amort Değeri] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[G10031].CopyFromRecordset RS
ActiveSheet.Protect "karzarar.org "
End Sub

 

[spacebar]

Konu güncelleme

 

[ÖmerFaruk]

Hangi sütundaki listenizin boyu daha büyüktür bilemiyorum.
Örnek olarak aşağıdkai şekilde yapabilirsin.

sorgu = "select [Fark Aktif Değeri] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[C31].CopyFromRecordset RS
Say = RS.RecordCount

sorgu = "select [Amortisman Muh Kodu] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
Set RS = con.Execute(sorgu)
s2.[E31].Offset(Say, 0).CopyFromRecordset RS

 

[spacebar]

üstad olmadı A-C sutunundaki veriler bittikten sonra E - G sutunu verileri gelmesi gerekiyordu. ancak A-C-E yanyana geldi.

 

[ÖmerFaruk]

s2.[E31].Offset(Say, 0)
E yerine A yazmayı deneyebilirsin

Biraz gayret edebilseniz, cesaret gösterbilseniz bunları kendiniz rahatlıkla çözeceksiniz.
Her daim balığı tutulmuş olarak aramayın.

 

[spacebar]

olmadı üstad. çok denedim ama olmadı.

 

[ÖmerFaruk]

Kodlarınız şu şekilde kullanabilirsiniz.

Sub kayitaktar()
Dim Rs As Object, Con As Object
    ActiveSheet.Unprotect "karzarar.org "
    Set s1 = Sheets("Data")
    Set s2 = Sheets("Muhasebe Kaydı")
    
    son = s1.Cells(Rows.Count, "A").End(3).Row
    'eski = s2.Cells(Rows.Count, "A").End(3).Row
    
    'If eski > 1 Then
    s2.Range("A31:G20030" & eski).ClearContents
        Set Con = VBA.CreateObject("AdoDb.Connection")
        Set Rs = VBA.CreateObject("AdoDb.Recordset")
    Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
    ThisWorkbook.FullName & ";extended properties=""Excel 12.0;hdr=yes"""
    
    sorgu = "select [SK Muh Kodu] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
    Rs.Open sorgu, Con, 1, 1
    s2.[A31].CopyFromRecordset Rs
    Rs.Close
    sorgu = "select [Fark Aktif Değeri] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
    Rs.Open sorgu, Con, 1, 1
    s2.[C31].CopyFromRecordset Rs
    Say = Rs.RecordCount
    Rs.Close
    sorgu = "select [Amortisman Muh Kodu] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
    Rs.Open sorgu, Con, 1, 1
    s2.[A31].Offset(Say, 0).CopyFromRecordset Rs
    Rs.Close
    sorgu = "select [Fark Amort Değeri] from [Data$A1:O" & son & "] where Kod>0 order by [Kod]"
    Rs.Open sorgu, Con, 1, 1
    s2.[C31].Offset(Say, 0).CopyFromRecordset Rs
    Rs.Close
    If Rs.State <> 0 Then Rs.Close
    If Con.State <> 0 Then Con.Close
    Set Rs = Nothing: Set Con = Nothing
    ActiveSheet.Protect "karzarar.org "
End Sub

 

[spacebar]

üstad küçük bir düzenleme gerekiyordu. onu yaptım. sorunsuz çalışıyor. bir çok meslektaşımın kullanacağı bir çalışma olacak. ellerinize sağlık. iyi pazarlar dilerim.