• DİKKAT

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

VBA'de string dizisine tarama ile veri alma

A

auroraborealis94

Katılım
23 Mart 2017
Mesajlar
35
Excel Vers. ve Dili
2016 ingilizce
Hocam merhabalar, bitirme projesi yapıyoruz. Vba ile bir kodlama işine giriştik.
Kısaca yapmak istediğim şeyi yazayım:

Elimizde bir sürü veri var, biz bu verileri ilk olarak korelasyona sokuyoruz. Korelasyon çıktısında oluşan matristeki değerler -1 ile +1 arası değerler alıyor.
İkinci olarak korelasyon matrisindeki verileri tarayarak 0,3ten büyük ve -0,3ten küçük verilerin hücrelerine bakıyoruz
Bu baktığımız hücrelerin bildiğiniz gibi en üst satırında ve en sol sütununda verilerin isimleri yer alıyor.
Bu isimleri tutması gereken bir string arrayi tanımlıyoruz
Yazdığım kodda yukarıdaki dediklerimi yapmaya çalıştım
Kod şu şekilde:

Sub correlationhighlight()
Dim veriRange As Range
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim Arr() As Variant
Arr = Range("B3:AH35")

Dim MyArray(32, 32) As String

count = 1



' For Each cell In [ActiveWorkbook]

For i = 0 To 34

For j = 0 To 35

If (Cells(i + 2, j + 3) >= 0.3 Or Cells(i + 2, j + 3) <= -0.3) Then

MyArray(i, 1) = Cells(i + 2, 1)

MyArray(i, count) = Cells(1, j + 3)

End If
count = count + 1
Next j

Next i

End Sub

Sarı ile işaretleridiğim yerder için "subscript out of range" hatası veriyor.

Lütfen yardım ediniz
Teşekkürler...
 
İlk göze çarpan, "i" sayacı >32 olduğunda (33 veya 34 olduğunda) "MyArray" dizisinin (0 to 32) dışında kaldığından "aralığın dışında" hatası oluşur.
 
Zeki Gürsoy' Alıntı:
İlk göze çarpan, "i" sayacı >32 olduğunda (33 veya 34 olduğunda) "MyArray" dizisinin (0 to 32) dışında kaldığından "aralığın dışında" hatası oluşur.
Genişletmek için tıkla ...


Hocam son hali şöyle:

For i = 2 To 35

For j = i + 1 To 36


If (Cells(i, j) >= 0.3 Or Cells(i, j) <= -0.3) Then

MyArray(i - 2, 0) = Cells(i, 1)

MyArray(i, count) = Cells(1, j)

count = count + 1

End If
count = 0
Next j

Next i


MyArray (50,50) yaptım yine aynı problem yaşanıyor yani 32den 50ye kadar tek tek denedim :d

for döngüsünü bu hale getirdim çünkü matris üçgen halinde yani sağ üst kısmı yok

ama sıkıntı şu ki hatayı aldıktan sonra i'nin üzerine geliyorum i=4 diyor j de aynı şekilde 4. Yani 4ten sonrasına gitmiyor.
 
Peki "count" değişkeninin değerini kontrol ettiniz mi?
Bu değişkeni içerdeki "for" içine yazmışsınız.
Bu da demektir ki, "i=4" olana kadar artmış. Yani "count" değişkeninin değeri, yaklaşık "i * j" kadar olmuş.
Bu da (counter), "MyArray" dizisinin yine dışındadır.

Dikkat ediniz. :)

.
 
Zeki Gürsoy' Alıntı:
Peki "count" değişkeninin değerini kontrol ettiniz mi?
Bu değişkeni içerdeki "for" içine yazmışsınız.
Bu da demektir ki, "i=4" olana kadar artmış. Yani "count" değişkeninin değeri, yaklaşık "i * j" kadar olmuş.
Bu da (counter), "MyArray" dizisinin yine dışındadır.

Dikkat ediniz. :)

.
Genişletmek için tıkla ...

Zeki hocam şuan nasıl yaptım bilmiyorum ama hata almadan çalışıyor,
MyArray içine alıp neler kaydetti bir bakayım dedim, metin belgesine yazdırmayı denedim fakat boşluklar oluşuyor sadece. Yani excel içine nasıl yazdıracağımı bilmiyorum ama boş çıkıyor metin belgesinde. Yani şuan başka bir sorunum var MyArray string dizisi içine veriler neden alınmıyor sorunum oluştu. Excel dosyamda 4 adet sayfa var ben bunları "correlation" sayfasından çekmeye çalışıyorum MyArray dizisi içine. Tüm Kodu tekrar yolluyorum bana biraz daha yardımcı olursanız çok sevinirim:


Sub correlationhighlight()
Dim veriRange As Range
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim Arr() As Variant

Arr = Range("B3:AH35")

Dim MyArray(33, 33) As String

count = 1

For i = 2 To 35

For j = i + 1 To 36


If (Cells(i, j) >= 0.3 Or Cells(i, j) <= -0.3) Then

MyArray(i - 2, 0) = Cells(i, 1)

MyArray(i - 2, count) = Cells(1, j)

count = count + 1

End If
count = 1
Next j

Next i

Dim x As Integer
Dim y As Integer

Dim myfilepath As String
myfilepath = "C:\Users\User\Desktop\assad.txt"
Dim myFile As Integer
myFile = FreeFile

Open myfilepath For Append As #myFile

For x = 0 To 5
For y = 0 To 5
Print #myFile, MyArray(x, y)
Next y
Next x






End Sub
 
Dosyanız özel değilse bir upload sitesine ekleyip bağlantıyı buraya yazın.
Atlanan bir yer olup olmadığını test ederek kolayca bulalım.
 
Zeki Gürsoy' Alıntı:
Dosyanız özel değilse bir upload sitesine ekleyip bağlantıyı buraya yazın.
Atlanan bir yer olup olmadığını test ederek kolayca bulalım.
Genişletmek için tıkla ...

Tamam hocam hallettim. Link:

http://www.dosyaupload.com/8ORb

assad isimli text dosyası ismi var kodun içinde, masaüstüme açtığım boş bir metin belgesi.

Nolur yardımcı olun mezun olamayacağım diye korkuyorum vallahi
 
Deneyin...

Kod: 
Sub correlationhighlight()
    Dim i As Integer, j As Integer, syf As Worksheet
    
    Set syf = Sheets("corelation")
    
    Dim MyArray(1 To 34, 1 To 35) As String
    
    For i = 2 To 35
         
        For j = 2 To i
        
            If (syf.Cells(i, j) >= 0.3 Or syf.Cells(i, j) <= -0.3) Then
                
                MyArray(i - 1, 1) = syf.Cells(i, 1)
    
                MyArray(i - 1, j) = syf.Cells(i, j)
                
            End If
           
        Next j
        
    Next i
    
   [COLOR=DarkGreen] '**********************************************
    'Yeni çalışma kitabına listeleme[/COLOR]
    Dim x As Integer, y As Integer, wb As Workbook
    
    Set wb = Workbooks.Add
    
    For x = 1 To 34[COLOR=DarkGreen] 'satır[/COLOR]
    
        For y = 1 To 35[COLOR=DarkGreen] 'sütun[/COLOR]
        
            wb.Worksheets(1).Cells(x, y) = MyArray(x, y)
            
        Next y
        
    Next x
    
    wb.Worksheets(1).Cells.EntireColumn.AutoFit
    
End Sub
 
Zeki Gürsoy' Alıntı:
Deneyin...

Kod: 
Sub correlationhighlight()
    Dim i As Integer, j As Integer, syf As Worksheet
    
    Set syf = Sheets("corelation")
    
    Dim MyArray(1 To 34, 1 To 35) As String
    
    For i = 2 To 35
         
        For j = 2 To i
        
            If (syf.Cells(i, j) >= 0.3 Or syf.Cells(i, j) <= -0.3) Then
                
                MyArray(i - 1, 1) = syf.Cells(i, 1)
    
                MyArray(i - 1, j) = syf.Cells(i, j)
                
            End If
           
        Next j
        
    Next i
    
   [COLOR=DarkGreen] '**********************************************
    'Yeni çalışma kitabına listeleme[/COLOR]
    Dim x As Integer, y As Integer, wb As Workbook
    
    Set wb = Workbooks.Add
    
    For x = 1 To 34[COLOR=DarkGreen] 'satır[/COLOR]
    
        For y = 1 To 35[COLOR=DarkGreen] 'sütun[/COLOR]
        
            wb.Worksheets(1).Cells(x, y) = MyArray(x, y)
            
        Next y
        
    Next x
    
    wb.Worksheets(1).Cells.EntireColumn.AutoFit
    
End Sub
Genişletmek için tıkla ...


Zeki hocam çok teşekkür ederim bu sayede bir çok şey öğrendim. Fakat ilk başta yazdığım kodun amacı biraz farklı idi. Şöyle açıklayayım bana vermiş olduğunuz kod korelasyon sonuçlarında 0,3ten büyükse veya -0,3ten küçükse onlar haricindekileri eleyip yeni bir sayfada yazdırmak, benim yapmak istediğimse şöyle bir sıralamaya sahip:
1-Korelasyon tablosundaki 0,3ten büyük veya -0,3ten küçükleri belirlemek
2-İşaretlenen hücrelerin en üstlerinde yazan isimleri MyArray dizisi içinde en üst satıra yerleştirmek(mesela profit before tax MyArrayde 0,0da tutulsun, profit before tax ile ilişkisi olanlar yani 0,3ten büyük veya -0,3ten küçük katsayıya sahip olanların isimleri de 0,0 konumunun altında yer alsın yani MyArrayin birinci sütununun en üst satırında korelasyon tablosunda üst kısımdaki isimlerden ilki, sonrasında da korelasyon tablosunda ilişkili olanların en solundaki ismi de 0,1e 0,2ye 0,3e... kaydetsin)
3-MyArrayde sütunsal bakıldığında en üst satırda yer alan veri ile hangileri alakalı bunları görebilelim ki bu da o sütunun ilk verisinden sonrakiler ilişkili demek olsun
4-Size yolladığım excelde veri sayfası var yazdığımız kod MyArraya sütun bazında inceleme yaparak verileri belirlesin(örneğin MyArrayin birinci sütununda 5 adet isim var, bu isimleri veri sayfasında kontrol etsin ve bu isimlerin altında yer alan verileri regresyona soksun

Bundan sonrasında daha bir çok işimiz var Zeki hocam ama bana attığınız kodu yazabildiğinize göre bu konu ile ilgili yardımcı olmanız dişinizin kovuğunu bile doldurmaz diye düşündüm :)

Bu kısımda da bana yardımcı olursanız çok sevinirim umarım durumu iyi açıklamışımdır çünkü anlatması da anlaması da çok zor :kafa:
 
Ekteki dosyanızda bulunan mevcut verilerle elde etmek istediğiniz sonucu, elle tablo haline getirdikten sonra dosyayı buraya ekleyin.

Bu şekilde anlaşmak zor olacak. :)
 
Hatta countu ekleme sebebim de MyArray dizisinde boşluklar oluşmasın diyeydi Zeki hocam
 
Zeki Gürsoy' Alıntı:
Ekteki dosyanızda bulunan mevcut verilerle elde etmek istediğiniz sonucu, elle tablo haline getirdikten sonra dosyayı buraya ekleyin.

Bu şekilde anlaşmak zor olacak. :)
Genişletmek için tıkla ...

Zeki hocam matrisi artık doğru şekilde alabiliyorum :) buyrun sizin gönderdiğiniz kodda ufak değişiklikler yaptım ve son hali bu :

Sub correlationhighlight()
Dim i As Integer, j As Integer, syf As Worksheet
Dim count As Integer

Set syf = Sheets("corelation")

Dim MyArray(1 To 34, 1 To 34) As String

For i = 2 To 35 'sütun
count = 1
For j = i + 1 To 36 'satır

If (syf.Cells(j, i) >= 0.3 Or syf.Cells(j, i) <= -0.3) Then

MyArray(1, i - 1) = syf.Cells(1, i)

MyArray(count + 1, i - 1) = syf.Cells(j, 1)
count = count + 1
End If

Next j

Next i

'**********************************************
'Yeni çalışma kitabına listeleme
Dim x As Integer, y As Integer, wb As Workbook

Set wb = Workbooks.Add

For x = 1 To 34 'satır

For y = 1 To 34 'sütun

wb.Worksheets(1).Cells(x, y) = MyArray(x, y)

Next y

Next x

wb.Worksheets(1).Cells.EntireColumn.AutoFit

End Sub


Bunun çıktısını aldığınızda oluşan workbook tam da istediğim gibi :)

şimdi bu oluşan matrisi sütun sütun veri sayfasının ilk satır verileriyle karşılaştırmam ve eşleşenleri regresyon analizine sokmam gerekiyor :)

Mutluluktan ağlayacağım uzun zamandır böyle güzel bir şey yaşamamıştım :icelim:
 
Yanlış anlamadıysam, "if" kuralına uyan başlık ve değerler "yatay" olarak listelenecek.
Peki, "B" sütunu da "A" sütunu listesinin altına mı "yatay" olarak listelenecek?

Mesaj içeriğindeki kodu "code" tag ları içine alalım. Okuması zor oluyor.

.
 
Zeki Gürsoy' Alıntı:
Yanlış anlamadıysam, "if" kuralına uyan başlık ve değerler "yatay" olarak listelenecek.
Peki, "B" sütunu da "A" sütunu listesinin altına mı "yatay" olarak listelenecek?

Mesaj içeriğindeki kodu "code" tag ları içine alalım. Okuması zor oluyor.

.
Genişletmek için tıkla ...

Hocam bahsettiğiniz şey MyArraye veri atarken mi yoksa MyArray ile veri sayfasının ilk satırını karşılaştırırken mi onu anlayamadım. Tavsiyeniz için teşekkür ederim bundan sonra kullanırım :) açıklamayı şöyle genişleteyim Zeki Hocam:

#A B C ....
a
b
c
.
.
.

Belirttiğim kodda kullandığımız MyArray string dizisi "dikey" olarak veri kaydediyor, her bir sütunun ilk satırına büyük harfi koyuyor diyelim(başlıklar yerine harf kullanalım, büyük ve küçük harfleri sadece belirtmek için kullanıyorum yoksa aynı başlıklar farkları yok yani). Burada ilk satıra koyulan başlıkların "ilk satır"a koyulmasını istememin sebebi regresyon analizinde kullanılacak verilerden ilkinin y değişkeni olmasını istediğim için. Mesela yukarıdaki örnek için şöyle bir dizi sütunu oluştu diyelim:

A
b
d
e
f

Bu durumda "veri" sayfasına gidip a,b,d,e ve f başlıklarının altında bulunan 36şar veriyi başlıklarıyla beraber farklı bir sayfaya kopyalayıp yapıştırmak istiyoruz.(Yeni bir sayfa oluşturmadan da yapabiliyorsak çok daha iyi olur elbette çünkü bu yaptığımız proje şirket tarafından devamlı olarak kullanılacak, en kötü halle regresyon yapılıp istenilen veriler aldıktan sonra sayfayı silelim diye düşünüyorum)

Yeni oluşan sayfa MyArray dizisinin her bir sütunu için tekrarlanmalı(belirtmek isterim ki gönderdiğim kodda MyArray dizisi içerisinde boş sütunlar da oluşuyor onu kaldırabilirsem işimiz çok daha kolay hale gelecektir). Yeni sayfada belirttiğim başlıklar ve değerler yer aldıktan sonra bu verileri regresyon analizine sokmamız gerekiyor.

Bu arada B sütunu A sütununun altına değil yanına kaydedilmeli çünkü her bir sütun için yeni bir regresyon analizi yapılacak. Ama eğer diyorsanız ki her bir sütun için regresyon analizini B sütununu A sütununun altına kaydederek daha kolay yaparız, o zaman problem yok(MyArray dizisini kullanıcının görmesi gerekli değil şuan için ben kodu doğru yazabildim mi onu görmek için bir çıktı alma ihtiyacı duyuyorum sadece) :alkolik:
 
Final

Merhaba;

Yazılanlardan konuyu anlamaya çalışarak bir çalışma hazırladım.

Hazırladığım model, Array' ın yalnız tek boyutunun resize oluşundan kaynaklanan kısıtlama nedeniyle sonuçları çok daha esnek olan XML biçimine çevirdim.

XML yapısı incelendiğinde bir tablo hiyerarşisinde olduğu açıkça görünmektedir.

Bu aşamadan sonra XML içeriği ister bir Array'a, ister bir Excel sayfasına listelenelenerek regresyon analizi yapılabilir veya bu analiz doğrudan XML üzerinde de yapılabilir.

Ben tabloyu yeni bir çalışma kitabına listelettim. Tablo biçimi değiştrilmek istenirse, herhangi bir VBA kullanıcısı tarafından XML dosyası farklı bir Excel tablosu biçimine kolayca çevrilebilir.

Benden bu kadar; kolay gelsin...

Uzun mesajları alıntı yapmayın...

İndirme dosyası local : http://www.excel.web.tr/attachment.php?attachmentid=186683&stc=1&d=1490700841
İndirme dosyası dış : http://s9.dosya.tc/server2/nf8q1j/asd2.zip.html
----------------------------------------------------------------
Programı aşağıdaki buton ile çalıştırabilirsiniz :

attachment.php


XML biçimindeki tablo yapısı :

attachment.php


XML tablonun Excel tablosuna dönüşümü :

attachment.php


Program kodu :
Kod: 
[SIZE=2]Public Sub OnActionButton(control As IRibbonControl)
    [COLOR=DarkGreen]'Ribbon daki butona basıldığında[/COLOR]
    Select Case control.id
        Case "btn0"
            Dim xmlDoc As Object, XMLString As String
    
            Set xmlDoc = Generate_XML
            
            xmlDoc.Save ThisWorkbook.Path & "\results.xml"
            
           [COLOR=DarkGreen] 'XML i biçimli görebilmek için tarayıcı ile açalım[/COLOR]
            With CreateObject("InternetExplorer.Application")
                .visible = True
                .Navigate ThisWorkbook.Path & "\results.xml"
            End With
            
            XMLString = xmlDoc.XML
            
           [COLOR=DarkGreen] 'MsgBox XMLString[/COLOR]
            
            Call Load_XML_To_New_WorkBook(XMLString)
            
            [COLOR=DarkGreen]'Call Load_XML_To_New_WorkBook(ThisWorkbook.Path & "\results.xml")[/COLOR]
    End Select
End Sub

Private Function Generate_XML() As Object
    Dim doc As Object, comment As Object, declaration As Object, adr As String
    Dim rws As Object, rw As Object, col As Object, data As Object, vl As Object
    Dim i As Integer, j As Integer, k As Integer, shCor As Worksheet, shVeri As Worksheet, differentColumn As Boolean
    
    Set shCor = ThisWorkbook.Worksheets("corelation")
    Set shVeri = ThisWorkbook.Worksheets("veri")
    
    Set doc = CreateObject("MSXML2.DOMDocument")
    
    Set declaration = doc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'")
    doc.appendChild declaration
    
    [COLOR=DarkGreen]'Belgeye imza bırakabilirsiniz.[/COLOR]
    Set comment = doc.createComment(vbNewLine & "Zeki GÜRSOY © 2017" & vbNewLine & "gursoyzeki@gmail.com" & vbNewLine & Now & vbNewLine)
    doc.appendChild comment
    
    Set rws = doc.createElement("rows")
    doc.appendChild rws
   
    For i = 2 To 34 [COLOR=DarkGreen]'sütun[/COLOR]
        
        differentColumn = True
        
        For j = i + 1 To 35[COLOR=DarkGreen] 'satır[/COLOR]
        
            If shCor.Cells(j, i) >= 0.3 Or shCor.Cells(j, i) <= -0.3 Then
                
                If differentColumn = True Then
                
                    Set rw = doc.createElement("row")
                    rw.setAttribute "info", "correlation sayfasının " & Cells(1, i).Address(0, 0) & " hücresinden gelen"
                    rw.Text = shCor.Cells(1, i)
                    rws.appendChild rw
                        
                    differentColumn = False
                    
                End If
                    
                Set col = doc.createElement("column")
                col.setAttribute "info", "correlation sayfasının A" & j & " satırından gelen"
                col.setAttribute "value", CDbl(shCor.Cells(j, i))
                col.Text = shCor.Cells(j, 1)
                rw.appendChild col
                
                adr = Left(Cells(1, j + 1).Address(0, 0), Len(Cells(1, j + 1).Address(0, 0)) - 1)
                Set data = doc.createElement("data")
                data.setAttribute "info", "veri isimli sayfanın " & adr & "2:" & adr & "37 aralığından gelen"
                col.appendChild data

                For k = 2 To 37[COLOR=DarkGreen] 'veri isimli sayfadan[/COLOR]

                    Set vl = doc.createElement("value")
                    vl.setAttribute "datacell", adr & k
                    vl.Text = CDbl(shVeri.Cells(k, j + 1))
                    data.appendChild vl

                Next
            End If
    
        Next
        
    Next
    
    Set Generate_XML = doc
    
End Function

Private Sub Load_XML_To_New_WorkBook(ByRef XML_FileNameOrString As Variant)
    Dim doc As Object, colColumns As Object, colRows As Object, colValues As Object
    Dim wb As Workbook, sh As Worksheet, r As Integer, c As Integer, v As Integer, isFile As Boolean
    
    If Not CStr(XML_FileNameOrString) Like "*xml version*" Then isFile = True
    
    
    Set doc = CreateObject("MSXML2.DOMDocument")
    
    doc.async = False [COLOR=DarkGreen]'XML tamamen yüklenene kadar işlem yapmasın demektir[/COLOR]
    
    If isFile = False Then
       [COLOR=DarkGreen] 'Bir XML dosyası değilse[/COLOR]
        doc.LoadXML CStr(XML_FileNameOrString)
    Else
       [COLOR=DarkGreen] 'Disk üzerindeki bir XML dosyası ise[/COLOR]
        doc.Load CStr(XML_FileNameOrString)
    End If
    
    Set wb = Workbooks.Add
    Set sh = wb.Worksheets(1)
    
    Set colRows = doc.SelectNodes("/rows/row")
    
    For r = 0 To colRows.Length - 1
        
        sh.Cells(r * 38 + 1, "a") = colRows(r).Text
        
        sh.Cells(r * 38 + 1, "a").Interior.Color = vbRed
        
        Set colColumns = colRows(r).SelectNodes("column")
        
        For c = 0 To colColumns.Length - 1
            
            sh.Cells(r * 38 + 1, c + 2) = colColumns(c).FirstChild.Text
            
            sh.Cells(r * 38 + 1, c + 2).Interior.Color = vbYellow
            
            Set colValues = colColumns(c).SelectNodes("data/value")
            
            For v = 0 To colValues.Length - 1
                
                sh.Cells(r * 38 + v + 2, c + 2) = CDbl(colValues(v).Text)
                
                sh.Cells(r * 38 + v + 2, c + 2).Interior.ColorIndex = 24
                
            Next
            
        Next
        
    Next
    
    sh.Range("a1:z1").EntireColumn.ColumnWidth = 30
    
End Sub[/SIZE]
 

Ekli dosyalar

  • Ekran Alıntısı0.jpg
    Ekran Alıntısı0.jpg
    21.1 KB · Görüntüleme: 20
  • Ekran Alıntısı.JPG
    Ekran Alıntısı.JPG
    143.6 KB · Görüntüleme: 20
  • Ekran Alıntısı2.JPG
    Ekran Alıntısı2.JPG
    98.6 KB · Görüntüleme: 18
  • asd2.xlsm
    asd2.xlsm
    67.1 KB · Görüntüleme: 8
Tüm yardýmlarýnýz için teþekkür ederim Zeki hocam :)
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst