• DİKKAT

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

Makromdaki Hata Nedir?

Katılım
1 Ocak 2010
Mesajlar
87
Excel Vers. ve Dili
Türkçe 2007
Merhaba arkadaşlar aşağıdaki gibi bir kod yazdım ancak alan 18 de bulunan veri ile karşılaştırmayı yaptıramıyorum. Sorun nedir acaba?





Sub test()

Dim cn As New ADODB.Connection
Dim rs As ADODB.Recordset
Dim ws As Worksheet
Dim ktiter As String
Dim satir As Range
Dim satirno As Long
Dim sutun As Integer
Dim ws2 As Worksheet
Dim toplamsatir As Long
Dim alan18icin As String
Dim ws3 As Worksheet
Dim r1 As Range
Dim r2 As Range

Set ws = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set ws3 = Worksheets("Sheet3")

With cn
.Provider = "Microsoft.JET.OLEDB.4.0"
.Open ("c:\Havuz\Havuz.mdb")
End With

ws2.Rows(1).Value = ws.Rows(1).Value


'satirno = 1

satirno = ws3.Cells(1, 2)
toplamsatir = ws3.Cells(2, 2)

sutun = 20

'toplamsatir = ws.Range("A1").CurrentRegion.Rows.Count

Do

'ws2.Rows(satirno).Value = ws.Rows(satirno).Value
ws.Select
Range(Cells(satirno, 1), Cells(satirno, 20)).Copy



ws2.Select
Range(Cells(satirno, 1), Cells(satirno, 20)).PasteSpecial (xlPasteAll)

kriter = Worksheets("Sheet1").Cells(satirno, 1)
alan18icin = Worksheets("Sheet1").Cells(satirno, 14)

If Not kriter = "" Then

Set rs = New ADODB.Recordset

rs.Open "SELECT DISTINCT HAKSAHIBI, TEMSILORANI, DAGITIMNOTU, Alan18 FROM Havuz_temsili WHERE SARKI='" + kriter + "'", cn, adOpenStatic, LockType:=adLockOptimistic
Do Until rs.EOF

'Worksheets("Sheet2").Cells(2, 1) = "SELECT SARKI FROM Havuz WHERE SARKI='" + kriter + "'"
Worksheets("Sheet2").Cells(satirno, sutun) = rs.Fields(0).Value
Worksheets("Sheet2").Cells(satirno, sutun + 1) = rs.Fields(1).Value
Worksheets("Sheet2").Cells(satirno, sutun + 2) = rs.Fields(2).Value

If rs.Fields(2).Value <> alan18icin Then
Worksheets("Sheet2").Cells(satirno, sutun + 3) = rs.Fields(3).Value
End If

'Worksheets("Sheet2").Cells(satirno, sutun) = alan18icin


rs.MoveNext
sutun = sutun + 5
Loop
sutun = 20
rs.Close
Set rs = Nothing
End If

satirno = satirno + 1

Loop Until satirno = toplamsatir

cn.Close
Set cn = Nothing
End Sub
 
Geri
Üst