Makroyu Tüm Sayfalara Genişletme

[lacheros]

Merhaba. Elimdeki makro kodunu 30 sayfada birden çalışacak hale getirmem lazım. Vba bilmiyorum çok fazla. bu kodlarıda internetten araştırarak buldum. Yazdığım makro sadece sheet1 de çalışıyor ama işlemleri 30 sheet te birden yapması lazım data sayısı en az 24x65000 olduğu için. Şöyle anlatıyım, sheet1, sheet2,...,sheet30 un A sütununa değerler girilcek ve makro bu değerleri küçükten büyüğe sıralayıp gerekli işlemleri yapacak. yardımcı olabilirseniz çok sevinirim.

Sub deneme()
Range("A1").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("A1:A65000") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A1:A65000")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
n = Application.WorksheetFunction.CountA(Range("A1:A65000"))

If n Mod 2 = 0 Then
    m = n / 2
Else
    m = (n + 1) / 2
End If
    
For i = m To n - 1
    Cells(i, 3) = Abs(Cells(i, 1) - Cells(i + 1, 1))
    Cells(i, 4) = Application.StDev(Range("A1:A" & i))
    If Cells(i, 4) < Cells(i, 3) Then
        Cells(i, 5) = i + 1
        End If
Next i

sinir = Cells(Application.WorksheetFunction.Min(Range("E1:E65000")), 1)

For l = m To n
    If Cells(l, 1) >= sinir Then
    Range("A" & l).Interior.Color = RGB(255, 0, 0)
    End If
    Next l
Columns("B:F").Select
Selection.Delete Shift:=xlToLeft

Cells(1, 2) = " Büyük Hasar Siniri"
Cells(1, 3) = sinir
End Sub

 

[mancubus]

tabii dosyayı görmek daha sağlıklı olurdu...

dosyada sadece işlem yapılacak kadar sayfa olduğu ve bunların sıralı olduğu varsayımı ile...

Sub deneme()

For ws = 1 To 30
Worksheets(ws).Activate

'mevcut kodların tamamı
'...
'...

Next ws

End Sub

 

[lacheros]

elimde data olmadığı için dosyayı koymadım. deneme amaçlı başka birisine gönderiyorum excel dosyasını o bana geri dönüş yapıyor. yardımınız için teşekkür ederim. sizin yazdıgınız kod galiba her sheet için ayrı ayrı yapıyor işlemleri. benim istediğim sheet1 ile sheet2 yi kendi içinde değilde birlikte alarak sıralama yapması.

 

[mancubus]

rica ederim.

"birlikte alarak sıralamak" ne demek bilmediğim bu kısıma bir cevabım yok maalesef.

 

[lacheros]

şöyle söyliyim. sheet1 ve sheet2 deki a sütunlarını tek bir veri gibi algılayıp işlem yapıcak. yani sheet1 deki a sütunu sort işleminden sonra en küçük veriden başlayacak sheet2 deki a sütununda sıralamaya devam ederek büyüge dogru gidecek.

 

[lacheros]

sorun farklı bir hal aldı. yardımcı olabilir misiniz acaba? 30 ayrı sheetten vazgeçtiler( ki en başta mantıklı olanda oydu) 30 kolonda olucak veri. veriyi sıralı olarak giricekler. ben sadece yukardaki işlemleri yapıcam yine. datanın median ı hangi hücrede onu bulup o hücreden son hücreye kadar işlemleer yapılacak.

 

[mancubus]

örnek dosya olmadan ben cevap veremem.

eğer yüklenebilirse örnek dosya mevcut durumu ve hazırlanacak makro çalıştıktan sonraki durumu temsili olarak göstermeli.

 

[lacheros]

Ornek bir dosya ekledim. Dataları kendim simule ettim. Sadece 4 kolon ekleyebildim ama makro 30 kolona kadar çalışabilmeli.

 

[mancubus]

talebitxt dosya olarak eklemek yerine mesajın içine yazmak daha uygun olur.
anladığım kadarı ile 30 sütun X 65.000 satır olarak girilen veri aslında 1.950.000 satırlık tek bir sütun. sığmadığı için 30 sütuna bölünüyor.

konu biraz istatistik mühendislik gerektiriyor. beni aşar.

ilgilenmek isteyenler için txt dosyadaki talebi buraya ben ekleyeyim:


___________________


Eleman sayısı maksimum 30x65000 olacak ve girilen veriler sıralı olarak girilecek. Makronun yapması gereken aşağıda
anlatılmıştır.

Makronun algoritması:
1- İlk olarak data nın median değerinin olduğu hücre bulunacak.
Median için data sayısına "n" dersek, n çift ise median=n/2, tek ise median=(n+1)/2 inci data oluyor ama hücre
indisi ne olur bilemiyorum.

2- Daha sonra data nın son hücresinden başlayarak bir önceki ile olan farkı hesaplanacak.
Yani 35 datamız var ise 35-34, 34-33, 33-32,...,19-18 değerleri data nın median ına kadar hesaplanacak.

3- Farklar hesaplandıktan sonra, data da bulunan son değer atılarak geri kalan data için standart sapma hesaplanacak
Sonra son iki değer atılarak standart sapma hesaplanacak. Sonra 3 değer atılarak. Yine median değerine kadar bu
hesap yapılacak.
35 data için ilk standartsapma(1,2,3,...,34). sonra standartsapma(1,2,3,...,33), standartsapma(1,2,3,...,32)

4- Sonra 2. ile 3. adımda buldugumuz değerler karşılaştırılacak. Yani (35-34) ile standartsapma(1,2,3,...,34)
(34-33) ile standartsapma(1,2,3,...,33)... değerleri karşılaştıralacak.

5- Eğer hesaplanan fark, diyelim ki (32-31), standart sapmadan büyükse, bu durumda standartsapma(1,2,3,...31),
32. datanın değeri bir kümede tutulacak. Bu karşılaştırmalar yapıldıktan sonra elimizde bir küme olacak.

6- Eğer elimizdeki kümede hiç eleman yoksa( bu ihtimalde var) B1 hücresine sınır değeri olarak Data daki en büyük
eleman ile standartsapma(tümdata) nın toplamı yazılacak.
7- Eğer kümemiz boş değilse B1 hücresine bulduğumuz kümenin minimum değeri sınır olarak yazılacak ve bu değerden
büyük bir değere sahip olan hücreler kırmızıya boyanacak.

 

[lacheros]

Dim vArr() As Variant    
   vArr = Range("C1:AF65000").Value

çabanız için yine de teşekkür ederim.
yukardaki kodlar ile kolonlardaki verileri alabiliyorum ama vArr çok boyutlu oluyor. Yine sorun oluyor bu yüzden. Onu tek boyutlu bir array yapabilir miyim acaba?

 

[mancubus]

önce C sütunundaki veriler, sonra D sütunundaki veriler, vs vs, en altta AF sütunudaki veriler alt alta sıralanacak ise

Sub arr1()

Dim vArr(), vArr1()
Dim i As Long, j As Long, k As Long, adet As Long

vArr = Range("C1:AF65000").Value
adet = (UBound(vArr, 1) - LBound(vArr, 1) + 1) * (UBound(vArr, 2) - LBound(vArr, 2) + 1)

ReDim vArr1(1 To adet)
For j = LBound(vArr, 2) To UBound(vArr, 2)
    For i = LBound(vArr, 1) To UBound(vArr, 1)
        k = k + 1
        vArr1(k) = vArr(i, j)
    Next
Next

vArr1 = Application.Transpose(vArr1)

End Sub