• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Vba Sql Verilerini Istediğim Sütuna Almak

K

koboy

Katılım
1 Ağustos 2006
Mesajlar
179
Merhaba vba ile excel veri çekiyorum istediğim çektiğim verilerde
bazı kısımlar üste olacak bakiye kısımları altında nasıl yapabilirim
 

Ekli dosyalar

Kasa_Detay makrosunda sondaki Msgbox satırından önce aşağıdaki satırları ekleyip dener misiniz?

PHP: 
sonA = Sayfa1.Cells(Rows.Count, "A").End(9).Row
Sayfa1.Range("A8:A" & sonA).Delete Shift:=xlToLeft

Düzeltme:
PHP: 
sonA = Sayfa1.Cells(Rows.Count, "A").End(3).Row
Sayfa1.Range("A8:A" & sonA).Delete Shift:=xlToLeft

Olacaktı .
 
Son düzenleme:
bu sekil yaptım olmadı
PHP: 
Sub Kasa_Detay()
Dim Server As String, Database As String, Kullanıcı As String, Parola As String
Dim sss As Long, Topla As Long, Son As Long, Say As Long, liste(), Veri(), Zaman As Double
Dim S1 As Worksheet, S2 As Worksheet, X As Long
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set S2 = Sheets("Ayar")
Zaman = Timer
'***********************************************************************************************************************************************
With Application
 .ScreenUpdating = False
End With
'Bağlantı Tanımlama************************************************************************************************************************************************
Range("A9:AZ" & Rows.Count).Borders.LineStyle = 0
Range("A9:AZ" & Rows.Count).ClearContents
Server = S2.Range("b2").Value:
Database = S2.Range("b3").Value:
Kullanıcı = S2.Range("b4").Value:
Parola = S2.Range("b5").Value
'Firma = Format(Mid(S2.Range("B1"), 4, 3), "000")
'Firmaa = Format(Mid(S2.Range("B1"), 4, 3), "000") * 1
'Dönem = Format(Mid(S2.Range("B1"), 1, 2), "00")
'KASA = Range("B1")
Set con = CreateObject("ADODB.Connection")
con.Open "Provider=SQLOLEDB; Data Source=" & Server & "; Initial Catalog=" & Database & "; User ID=" & Kullanıcı & "; Password=" & Parola & ";"
Set rs = CreateObject("adodb.recordset")
'Sql Kod************************************************************************************************************************************************
s = s & "  SELECT CLCARD.CODE as [KODU], CLCARD.DEFINITION_ as [UNVAN] , CLCARD.TELNRS1 as [TEL],CLFLINE.AMOUNT AS [BORÇ],CLFLINE.AMOUNT AS [ALACAK]"
s = s & "   FROM LG_211_CLCARD AS CLCARD INNER JOIN LG_211_01_CLFLINE AS CLFLINE ON CLCARD.LOGICALREF=CLFLINE.CLIENTREF "
s = s & "   WHERE CLCARD.ACTIVE=0 AND CLCARD.CODE='T-İTH130-110' "
con.CommandTimeout = 10000
rs.Open s, con
'Alttoplam Alma*********************************************************************************************************************************************


With Sayfa1
  For i = 0 To rs.Fields.Count - 1
Cells(8, i + 1).Value = rs.Fields(i).Name
Next i
  .Range("a9").CopyFromRecordset rs
    Son = .Range("a65536").End(3).Row
    .Columns.AutoFit
    .Range("b4").Value = rs.Fields(1).Value
    .Range("b5").Value = rs.Fields(2).Value

  End With


rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
'**********************************************************************************************************************************************
With Application
        .ScreenUpdating = True
        
        
        
        
End With
sonA = Sayfa1.Cells(Rows.Count, "A").End(9).Row
Sayfa1.Range("A8:A" & sonA).Delete Shift:=xlToLeft
    
MsgBox "İşleminiz Tamamlanmıştır. " & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman) / 60, "0.00") & " Saniye", vbInformation, "Tebrik"

End Sub
 
Yanlış yazmışım End(3) olacaktı .
 
Verdiğim kod A8:A son dolu satır arasını siliyor. O silme işlemini yapmadı mı? Eğer yaptıysa A8:C olarak kullanırsanız kod, unvan ve tel sütunlarını siler. SQL sorgusunu benim bilgisayarda yapamadığım için makro bende çalışmıyor, dolayısıyla deneyemiyorum maalesef.
 
ben asıl sunu istiyorum sorguyu çektim
kod unvan tel üstte yazacan
borç alacak alt satırdan başlayacak
sunu yapamıyor muyuz

SELECT CLCARD.CODE as [KODU],
CLCARD.DEFINITION_ as [UNVAN] ,
CLCARD.TELNRS1 as [TEL],



kodu [b4] unvan [b5] tel[6] bunlar yazacak

a8 den sonra
CLFLINE.AMOUNT AS [BORÇ],CLFLINE.AMOUNT AS [ALACAK] bunlar gelecek
 
SQL konusunda hiç bilgim yok desem yeridir. O nedenle mevcut durumda farklı bir çözüm önerdim. Eğer silme yapılıyorsa üst kısımdaki kod vs bilgilerini de kodla getirip sonra silinebilir. Örneğin:

Sayfa1.[B4] = Sayfa1.[A9]

gibi.
 
Makroyu aşağıdaki gibi dener misiniz?

PHP: 
'Bismillahirrahmanirrahîm.'
Sub Kasa_Detay()
Dim Server As String, Database As String, Kullanıcı As String, Parola As String
    Dim sss As Long, Topla As Long, Son As Long, Say As Long, liste(), Veri(), Zaman As Double
    Dim S1 As Worksheet, S2 As Worksheet, X As Long
    Dim con As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Set S2 = Sheets("Ayar")
    Zaman = Timer
    '***********************************************************************************************************************************************
    With Application
        .ScreenUpdating = False
    End With
    'Bağlantı Tanımlama************************************************************************************************************************************************
    Range("A9:AZ" & Rows.Count).Borders.LineStyle = 0
    Range("A9:AZ" & Rows.Count).ClearContents
    Server = S2.Range("b2").Value:
    Database = S2.Range("b3").Value:
    Kullanıcı = S2.Range("b4").Value:
    Parola = S2.Range("b5").Value
    Firma = Format(Mid(S2.Range("B1"), 4, 3), "000")
    Firmaa = Format(Mid(S2.Range("B1"), 4, 3), "000") * 1
    Dönem = Format(Mid(S2.Range("B1"), 1, 2), "00")
    KASA = Range("B1")
    Set con = CreateObject("ADODB.Connection")
        con.Open "Provider=SQLOLEDB; Data Source=" & Server & "; Initial Catalog=" & Database & "; User ID=" & Kullanıcı & "; Password=" & Parola & ";"
    Set rs = CreateObject("adodb.recordset")
    'Sql Kod************************************************************************************************************************************************
        s = s & "  SELECT CLCARD.CODE as [KODU], CLCARD.DEFINITION_ as [UNVAN] , CLCARD.TELNRS1 as [TEL],CLFLINE.AMOUNT AS [BORÇ],CLFLINE.AMOUNT AS [ALACAK]"
        s = s & "   FROM LG_211_CLCARD AS CLCARD INNER JOIN LG_211_01_CLFLINE AS CLFLINE ON CLCARD.LOGICALREF=CLFLINE.CLIENTREF "
        s = s & "   WHERE CLCARD.ACTIVE=0 AND CLCARD.CODE='T-İTH130-110' AND YEAR(CLFLINE.DATE_)='2018'"
        con.CommandTimeout = 10000
        rs.Open s, con, 1, 1
    'Alttoplam Alma*********************************************************************************************************************************************
    eski = WorksheetFunction.Max(9, Sayfa1.Range("a65536").End(3).Row)
    Sayfa1.Range("A9:E" & eski).ClearContents
    With Sayfa1
        For i = 0 To rs.Fields.Count - 1
            Cells(8, i + 1).Value = rs.Fields(i).Name
        Next i
        .Range("a9").CopyFromRecordset rs
        Son = .Range("a65536").End(3).Row
        .Columns.AutoFit
        .Range("b4").Value = rs.Fields(1).Value
        .Range("b5").Value = rs.Fields(2).Value
    End With
    rs.Close
    con.Close
    Set rs = Nothing
    Set con = Nothing
    '**********************************************************************************************************************************************
    End With
    Sayfa1.[B4] = Sayfa1.[A9]
    Sayfa1.[B5] = Sayfa1.[B9]
    Sayfa1.[B6] = Sayfa1.[C9]
    Sayfa1.Range("A8:A" & Son).Delete Shift:=xlToLeft
    Application.ScreenUpdating = True
    MsgBox "İşleminiz Tamamlanmıştır. " & Chr(10) & Chr(10) & _
        "İşlem süresi ; " & Format((Timer - Zaman) / 60, "0.00") & " Saniye", vbInformation, "Tebrik"
End Sub
 
hata verdi
End With bu kısımda
CODE=php] End With----------------- burada hata veriyor
Sayfa1.[B4] = Sayfa1.[A9]
Sayfa1.[B5] = Sayfa1.[B9]
Sayfa1.[B6] = Sayfa1.[C9]
Sayfa1.Range("A8:A" & Son).Delete Shift:=xlToLeft
Application.ScreenUpdating = True
MsgBox "İşleminiz Tamamlanmıştır. " & Chr(10) & Chr(10) & _
"İşlem süresi ; " & Format((Timer - Zaman) / 60, "0.00") & " Saniye", vbInformation, "Tebrik"
End Sub[/CODE]
 
bu şekilde çözüm buldum sizce doğru mu yol mu?
sonucu alıyorum doğru şekilde

PHP: 
'Bismillahirrahmanirrahîm.'
Sub Kasa_Detay()
Dim Server As String, Database As String, Kullanıcı As String, Parola As String
Dim sss As Long, Topla As Long, Son As Long, Say As Long, liste(), Veri(), Zaman As Double
Dim S1 As Worksheet, S2 As Worksheet, X As Long
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Set S2 = Sheets("Ayar")
Zaman = Timer
'***********************************************************************************************************************************************

'Bağlantı Tanımlama************************************************************************************************************************************************

Server = S2.Range("b2").Value:
Database = S2.Range("b3").Value:
Kullanıcı = S2.Range("b4").Value:
Parola = S2.Range("b5").Value
Firma = Format(Mid(S2.Range("B1"), 4, 3), "000")
Firmaa = Format(Mid(S2.Range("B1"), 4, 3), "000") * 1
Dönem = Format(Mid(S2.Range("B1"), 1, 2), "00")
KASA = Range("B1")
Set con = CreateObject("ADODB.Connection")
con.Open "Provider=SQLOLEDB; Data Source=" & Server & "; Initial Catalog=" & Database & "; User ID=" & Kullanıcı & "; Password=" & Parola & ";"
Set rs = CreateObject("adodb.recordset")
'Sql Kod************************************************************************************************************************************************
s = s & "  SELECT CLCARD.CODE as [KODU], CLCARD.DEFINITION_ as [UNVAN] , CLCARD.TELNRS1 as [TEL],CLFLINE.AMOUNT AS [BORÇ],CLCARD.TELNRS1 AS [ALACAK]"
s = s & "   FROM LG_211_CLCARD AS CLCARD INNER JOIN LG_211_01_CLFLINE AS CLFLINE ON CLCARD.LOGICALREF=CLFLINE.CLIENTREF "
s = s & "   WHERE CLCARD.ACTIVE=0 AND CLCARD.CODE='T-İTH130-110' AND YEAR(CLFLINE.DATE_)='2018'"
con.CommandTimeout = 10000
rs.Open s, con, 1, 1
'Alttoplam Alma*********************************************************************************************************************************************

'CEK*********************************************************************************************************************************************
kodu = rs.Fields(0).Value
unvan = rs.Fields(1).Value
tel = rs.Fields(2).Value
'ENDCEK*********************************************************************************************************************************************
With Sayfa1
 For i = 0 To rs.Fields.Count - 1
Cells(8, i + 1).Value = rs.Fields(i).Name
Next i
 .Range("a9").CopyFromRecordset rs
 Son = .Range("a65536").End(3).Row
 .Columns.AutoFit
    .Range("b4").Value = kodu
    .Range("b5").Value = unvan
    .Range("b6").Value = tel
    
   ' .Range("a4").Value = "Tabela"
    '.Range("a5").Value = "Unvan"

   End With






rs.Close
con.Close
Set rs = Nothing
Set con = Nothing
'**********************************************************************************************************************************************

sonA = Sayfa1.Cells(Rows.Count, "A").End(3).Row
Sayfa1.Range("A8:C" & sonA).Delete Shift:=xlToLeft
    
    
MsgBox "İşleminiz Tamamlanmıştır. " & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format((Timer - Zaman) / 60, "0.00") & " Saniye", vbInformation, "aaa"

End Sub
'**********************************************************************************************************************************************
 
Verdiğim kodda son end with fazlalık. Onu silin. Kodu deneyemediğim için böyle hatalar oluyor maalesef, kusura bakmayın.
 
hocam yapabilsem zaten sizi yormam dendim ama olmadı
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst