İyi Günler;
Office 2003 versiyonunda Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path, makrosu ile verileri rahat alırken, Office 2010 versiyonunda bir veriyi yaklaşık olarak 1 saatta veriyor neden olabilir.
Kodlar Aşağıdadır.
Office 2010 versiyonunda da hızlı bir şekilde verileri almak isdeğimizde ne gibi değişiklik veya makro nedir.
Sub yillaritopla()
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim no As String, arr(), sonsat As String
Sheets("geneltoplam").Select
If Range("B4").Value = "" Then
MsgBox "Dosya Numarası boş" & vbLf & "Bir dosya numarsı girmelisiniz.", vbCritical, "UYARI"
Range("B4").Select
Exit Sub
End If
no = Range("B4").Value
Range("B21:R35").ClearContents
son = Cells(20, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For j = 2 To son
If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
sonsat = Application.ExecuteExcel4Macro("CountA('" & ThisWorkbook.Path & _
"\[" & Cells(20, j).Value & "]yiltoplami'!C2)") + 6
For t = 1 To sonsat
If CStr(Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & _
Cells(20, j).Value & "]yiıtoplami'!R" & t & "C2")) = no Then
For i = 3 To 14
arr(i - 2) = arr(i - 2) + Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & _
Cells(20, j).Value & "]yiltoplami'!R" & t & "C" & i)
Next i
End If
Next t
For t = 21 To 32
Cells(t, j).Value = arr(t - 20)
Next
Erase arr
End If
Next j
End Sub
Office 2003 versiyonunda Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path, makrosu ile verileri rahat alırken, Office 2010 versiyonunda bir veriyi yaklaşık olarak 1 saatta veriyor neden olabilir.
Kodlar Aşağıdadır.
Office 2010 versiyonunda da hızlı bir şekilde verileri almak isdeğimizde ne gibi değişiklik veya makro nedir.
Sub yillaritopla()
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim no As String, arr(), sonsat As String
Sheets("geneltoplam").Select
If Range("B4").Value = "" Then
MsgBox "Dosya Numarası boş" & vbLf & "Bir dosya numarsı girmelisiniz.", vbCritical, "UYARI"
Range("B4").Select
Exit Sub
End If
no = Range("B4").Value
Range("B21:R35").ClearContents
son = Cells(20, "IV").End(xlToLeft).Column
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For j = 2 To son
If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
sonsat = Application.ExecuteExcel4Macro("CountA('" & ThisWorkbook.Path & _
"\[" & Cells(20, j).Value & "]yiltoplami'!C2)") + 6
For t = 1 To sonsat
If CStr(Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & _
Cells(20, j).Value & "]yiıtoplami'!R" & t & "C2")) = no Then
For i = 3 To 14
arr(i - 2) = arr(i - 2) + Application.ExecuteExcel4Macro("'" & ThisWorkbook.Path & "\[" & _
Cells(20, j).Value & "]yiltoplami'!R" & t & "C" & i)
Next i
End If
Next t
For t = 21 To 32
Cells(t, j).Value = arr(t - 20)
Next
Erase arr
End If
Next j
End Sub
