merhaba arkadaşlar dosyamdaki bazı hücrelere formül var ve bu formüllü hücreler korumalı yaptığım zaman aşağıdaki kod hata veriyor benim istediğim aşağıdaki kodu çalıştırdığımda korumalı hücreleri pas geçsin formüller bozulmasın bi yardım ederseniz çok sevinecekim
kodlar alıntıdır.
Option Base 1
Sub al_topla_ado_59()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim z As Object, a As Long, fso As Object, f, dosya As String
Dim sat As Long, i As Long, list(), myarr(), n As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("C2:C65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
MsgBox "A sütununda veri yok.'nci satırdan itibaren verileriniz olmalı", vbCritical, "U Y A R I"
Application.ScreenUpdating = False
End If
ReDim myarr(1 To 2, 1 To sat)
Set fso = CreateObject("Scripting.filesystemobject")
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set z = CreateObject("scripting.Dictionary")
list = Range("A2:A" & sat).Value
For i = 1 To UBound(list)
If Not z.exists(list(i, 1)) Then
n = n + 1
z.Add list(i, 1), n
myarr(1, n) = i
End If
Next
Erase list
For Each f In fso.getfolder(ThisWorkbook.Path).Files
dosya = f.Name
If dosya <> ThisWorkbook.Name Then
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & f & _
";extended properties=""excel 8.0;hdr=no"""
rs.Open "select first(F1),sum(F2) from [Sayfa1$A2:B65536] GROUP BY F1 ORDER BY F1;" _
, conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then rs.MoveFirst
Do While Not rs.EOF
If z.exists(rs(0).Value) Then
myarr(2, z.Item(rs(0).Value)) = myarr(2, z.Item(rs(0).Value)) + rs(1).Value
End If
rs.MoveNext
Loop
rs.Close
conn.Close
End If
Next
Set rs = Nothing
Set conn = Nothing
Set fso = Nothing
Set z = Nothing
ReDim Preserve myarr(1 To 2, 1 To UBound(myarr, 2))
If UBound(myarr) > 0 Then
For i = 1 To UBound(myarr, 2)
If myarr(1, i) <> "" And IsNumeric(myarr(1, i)) Then Cells(myarr(1, i) + 1, "C").Value = myarr(2, i)
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı" & vbLf & "email: polis-irfan@hotmail.com" & vbLf & "date : 28.02.2011", vbOKOnly + vbInformation, "POLİS"
End If
Erase myarr
Application.ScreenUpdating = True
End Sub
kodlar alıntıdır.
Option Base 1
Sub al_topla_ado_59()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim z As Object, a As Long, fso As Object, f, dosya As String
Dim sat As Long, i As Long, list(), myarr(), n As Long
Sheets("Sayfa1").Select
Application.ScreenUpdating = False
Range("C2:C65536").ClearContents
sat = Cells(65536, "A").End(xlUp).Row
If sat < 2 Then
MsgBox "A sütununda veri yok.'nci satırdan itibaren verileriniz olmalı", vbCritical, "U Y A R I"
Application.ScreenUpdating = False
End If
ReDim myarr(1 To 2, 1 To sat)
Set fso = CreateObject("Scripting.filesystemobject")
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
Set z = CreateObject("scripting.Dictionary")
list = Range("A2:A" & sat).Value
For i = 1 To UBound(list)
If Not z.exists(list(i, 1)) Then
n = n + 1
z.Add list(i, 1), n
myarr(1, n) = i
End If
Next
Erase list
For Each f In fso.getfolder(ThisWorkbook.Path).Files
dosya = f.Name
If dosya <> ThisWorkbook.Name Then
conn.Open "provider=microsoft.jet.oledb.4.0;data source=" & f & _
";extended properties=""excel 8.0;hdr=no"""
rs.Open "select first(F1),sum(F2) from [Sayfa1$A2:B65536] GROUP BY F1 ORDER BY F1;" _
, conn, adOpenKeyset, adLockReadOnly
If rs.RecordCount > 0 Then rs.MoveFirst
Do While Not rs.EOF
If z.exists(rs(0).Value) Then
myarr(2, z.Item(rs(0).Value)) = myarr(2, z.Item(rs(0).Value)) + rs(1).Value
End If
rs.MoveNext
Loop
rs.Close
conn.Close
End If
Next
Set rs = Nothing
Set conn = Nothing
Set fso = Nothing
Set z = Nothing
ReDim Preserve myarr(1 To 2, 1 To UBound(myarr, 2))
If UBound(myarr) > 0 Then
For i = 1 To UBound(myarr, 2)
If myarr(1, i) <> "" And IsNumeric(myarr(1, i)) Then Cells(myarr(1, i) + 1, "C").Value = myarr(2, i)
Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı" & vbLf & "email: polis-irfan@hotmail.com" & vbLf & "date : 28.02.2011", vbOKOnly + vbInformation, "POLİS"
End If
Erase myarr
Application.ScreenUpdating = True
End Sub