Belirli alanı farklı Kaydet yapma

[link_me]

Merhabalar,

-- Kaydet dediğimde U sütuna kadar verileri farklı kaydet nasıl yapabilirim.

Kodlar Ektedir.

Sub ADO_Kodlama()
 
If Sayfa1.Range("V3") = Empty Then
    MsgBox "Sorgulama yapmak için ""V3"" hücresine bir değer girmeniz gerekir!", vbCritical, "HATA"
    Exit Sub
End If
    
VeriKaynagi = ThisWorkbook.Path & "\kaynak.xlsx"
Set Baglan = CreateObject("adodb.connection")
Baglan.Open = "provider=" & Saglayici & ";data source=" & VeriKaynagi & ";extended properties=""" & Ozellik & ";hdr=no"""
    
Sorgu = "SELECT F2, F3, F4, F5, F6, F7, F8, F9, F10, F11, F12, F13, F14, F17, F18, F19, F20, F21, F22, F23 FROM [Sayfa1$A1:W10000] WHERE F1 = " & Sayfa1.Range("V3") & ""
    
Set Kayit = VBA.CreateObject("adodb.Recordset")
Kayit.Open Sorgu, Baglan, 1, 1
    
If Kayit.RecordCount > 0 Then
    Sayfa1.Range("A4:U" & Rows.Count).ClearContents
    Sayfa1.Range("A4:U" & Rows.Count).UnMerge
    Sayfa1.Range("A5:U" & Rows.Count).Clear
    dizi = Kayit.GetRows
    Range("B4").Resize(UBound(dizi, 2) + 1, UBound(dizi, 1) + 1).Value = Application.WorksheetFunction.Transpose(dizi)
    sonsat = UBound(dizi, 2) + 5
    [A4].Resize(sonsat - 4, 1) = Evaluate("Row(1:" & sonsat - 4 & ")")
    [A4:U4].Copy: Range("A5:U" & sonsat - 1).PasteSpecial Paste:=xlPasteFormats
    Range("alttablo").Copy Cells(sonsat, 2): [A2].Select
    Cells(sonsat, 2).Resize(5, 20).Replace What:="$4)", Replacement:="$" & sonsat - 1 & ")", LookAt:=xlPart
Else
    MsgBox "Veri yok!", vbCritical
End If
          
Set Kayit = Nothing
Set Baglan = Nothing
End Sub

 

[link_me]

soru çok mu zor acaba arkadaşlar yardımcı olabilen var mı?

 

[Korhan Ayhan]

Sorunuz zor olmayabilir ama sanırım kimse anlamamış. Bundan dolayı cevap gelmemiş olabilir.

Benim anladığım sayfadaki belirli alanı başka bir dosya olarak kaydetmek istiyorsunuz. Eğer durum böyleyse alanı kopyala yeni dosyaya değer ve biçim olarak yapıştır seçeneği işinize yarayacaktır.

Deneyiniz.

Option Explicit

Sub Sayfayi_Yedekle()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet
    
    Application.ScreenUpdating = False
    
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("ATESH")
    
    S1.Copy
    
    Set K2 = ActiveWorkbook
    
    On Error Resume Next
    ActiveSheet.DrawingObject.Delete
    Range("V:XFD").EntireColumn.Delete
    On Error GoTo 0
    
    Application.DisplayAlerts = False
    K2.SaveAs VBA.CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
    Application.PathSeparator & S1.Range("C4").Value & " " & S1.Cells(S1.Rows.Count, "F").End(3).Value, 51
    K2.Close
    Application.DisplayAlerts = True
    
    Set K1 = Nothing
    Set S1 = Nothing
    Set K2 = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Sayfadaki veriler masaüstüne yedeklenmiştir."
End Sub

 

[link_me]

Örnek dosyamı ekleyeyim.

şarta göre verilerimi çekiyorum.bazen 7 satır bazen 10 satır oluyor.

U Sütununa kadar olanki verilerimi Masaüstüne Excel olarak C4 ve F14 olarak kaydetmesini nasıl sağlayabilirim?

 

[Korhan Ayhan]

Ben önceki mesajımı revize ettim. O kodu bir deneyiniz.

 

[link_me]

Sayın Korhan Ayhan,

çalıştıramadım benim dosyanın üzerinde bakma şansınız var mıdır?

 

[Korhan Ayhan]

Kodu tekrar revize ettim. Deneyiniz.

 

[link_me]

Sn Korhan Ayhan ellerinize sağlık çok güzel görünüyor. fakat bir sıkıntım var

4-5 satırlık verilerde herhangi bir sıkıntı yok

--19 satırlık veriyi çektim ve kaydet yapınca .xlsx olarak kayıt yapmadı masaüstüne uzantısı olmayan bir veri kaydetti ve veri açılmıyor.
--Kodlar ile ilgili açıklama yapabilir misiniz öğrenmem açısından neyin ne işe yaradığı hakkında

Teşekkürler

 

[Korhan Ayhan]

Durumun veri sayısı ile alakalı olduğunu sanmıyorum. Keza dosyanızdaki verileri 50 satıra çoğaltıp denediğimde sorun yaşamadım. Sizin sisteminizde başka bir sorun olabilir.

 

[link_me]

çok ilginç ama onca veri arasından bir tane firma var sadece o çalışmıyor.