array

[mars2]

İyi Günlere;
Tablomun C sutununda 1000adet isim bulmaktadır.
Kodda Array satırına 1000 adet ismi yazmamın mümkün olmadığından bu satırı nasıl düzenleriz.

arr()

arr = Array(Hasan, İsa, Mehmet, Mustafa,)

 

[Levent Menteşoğlu]

Bu diziyi ne amaçla kullanacaksınız.

 

[mars2]

Sayuın Levent Menteşoğlu;
Kapalı dosyadan isme göre veri çekmek için

 

[mars2]

Aşağıdaki kodu B12 hücresinde isim bulunmaktadır. Buna göre ayarlamak istiyorum.
Kodda gerekli düzeltmeler nelerdir.

Sub verial()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim ad As Variant, arr()

Sheets("yıllar").Select

If Range("B12").Value = "" Then
MsgBox "İsim Boş" & vbLf & "Bir İsim Girmelisiniz.", vbCritical, "UYARI"
Range("B12").Select
Exit Sub
End If

ad = Range("B12").Value

Range("B21:IV32").ClearContents

son = Cells(20, "IV").End(xlToLeft).Column

Application.ScreenUpdating = False

For j = 2 To son

If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open ("provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls;extended properties=""excel 8.0;hdr=ad""")
rs.Open "Select * from [toplam$A6:O65536];", conn, adOpenKeyset, adLockReadOnly
arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0)
rs.MoveFirst
Do While Not rs.EOF
'MsgBox rs(1)
If rs(1).Value = ad Then

For i = 21 To 32

If Not IsNull(rs(i - 19).Value) Then
arr(i - 20) = arr(i - 20) + rs(i - 19).Value
End If
Next i
End If
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
For t = 21 To 32
Cells(t, j).Value = arr(t - 20)
Next
Erase arr
End If
Next j

toplayuzdeal2

Application.ScreenUpdating = True
MsgBox "İSİM BAZINDA İŞLEM TAMAMLANMIŞTIR." & vbLf & _
"2009-2024 YILLARI", vbOKOnly + vbInformation, "K A Y Y I M L I K S E R V İ S İ"


If MsgBox("YAZDIRMA İŞLEM YAPILACAK MI?", vbYesNo + 32, "DİKKAT !") = vbNo Then

Else

ActiveSheet.PrintOut

End If

End Sub

 

[mars2]

Konu hakkında yardımlarınız beklemekteyim.

 

[Zeki Gürsoy]

Merhaba,

Diziye şimşek hızında aşağıdaki gibi alın; ve kullanımına da aşağıdaki örnekte gördüğünüz gibi dikkat edin. Alt index daima "1" dir.

dim arr as variant

arr = range("a1:a1000").value

for i=1 to 1000
    debug.print arr(i, 1)
next

erase arr

 

[mars2]

Sayın Zeki Gürsoy;
İlginiz için teşekkürler. Uygulamama rağmen olmadı.
arr = Array(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0) satırı çıkartıp
arr = range("c1:c1000").value

for i=1 to 1000
debug.print arr(i, 1)
next

erase arr
satırları eklemem rağmen hata vermektedir.

 

[Zeki Gürsoy]

Sub verial()
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Dim j As Integer, i As Byte, tpl As Double, dosya As String, son As Integer
Dim ad As Variant, [B]arr As Variant[/B]

    Sheets("yıllar").Select
    
    If Range("B12").Value = "" Then
        MsgBox "İsim Boş" & vbLf & "Bir İsim Girmelisiniz.", vbCritical, "UYARI"
        Range("B12").Select
        Exit Sub
    End If
    
    ad = Range("B12").Value
    
    Range("B21:IV32").ClearContents
    
    son = Cells(20, "IV").End(xlToLeft).Column
    
    Application.ScreenUpdating = False

    For j = 2 To son
    
        If Dir(ThisWorkbook.Path & "\" & Cells(20, j).Value & ".xls") <> "" Then
        
            Set conn = New ADODB.Connection
            Set rs = New ADODB.Recordset
            
            conn.Open _
                "provider=microsoft.jet.oledb.4.0;data source=" & _
                ThisWorkbook.Path & "\" & Cells(20, j).Value & _
                ".xls;extended properties=""excel 8.0;hdr=ad"""
                
            rs.Open "Select * from [toplam$A6:O65536];", conn, adOpenKeyset, adLockReadOnly
            
            [B]arr = Range("c1:c1000").Value[/B]
            
            rs.MoveFirst
            
            Do While Not rs.EOF
                'MsgBox rs(1)
                If rs(1).Value = ad Then
                
                    For i = 21 To 32
                    
                    If Not IsNull(rs(i - 19).Value) Then
                        [B]arr(i - 20, 1)[/B] = [B]arr(i - 20, 1)[/B] + rs(i - 19).Value
                    End If
                    
                    Next i
                End If
                
                rs.MoveNext
            Loop
            
            rs.Close
            
            Set rs = Nothing
            
            conn.Close
            
            Set conn = Nothing
            
            For t = 21 To 32
                Cells(t, j).Value = [B]arr(t - 20, 1)[/B]
            Next
            
            Erase arr
            
            End If
    Next j

    toplayuzdeal2
    
    Application.ScreenUpdating = True
    MsgBox "İSİM BAZINDA İŞLEM TAMAMLANMIŞTIR." & vbLf & _
    "2009-2024 YILLARI", vbOKOnly + vbInformation, "K A Y Y I M L I K S E R V İ S İ"
    
    
    If MsgBox("YAZDIRMA İŞLEM YAPILACAK MI?", vbYesNo + 32, "DİKKAT !") = vbNo Then
    
    Else
    
    ActiveSheet.PrintOut
    
    End If

End Sub

 

[mars2]

Sayın Zeki Gürsoy;
Kodu aynen kopyalayıp yapıştırıp çalıştırdığımda, aynı sayfanın c sutunundaki bilgileri almaktadır.

Yapmak istediğim ise klasörün içinde çalışma Yıllar toplamı adlı kitabının "yıllar" sayfası bulunmakta olup, Bu çalılma sayfasındaki B12 hücresine isim yazdığımızda kapalı bulunan dosyalardan (2009, 2010,2011...) verileri getirmek istiyorum örnek ektedir.

Kıstas İsme göre

 

[mars2]

Arkadaşlar;
Bu konu hakkında buğüne kadar yardım beklemekteyim.