Kodlama Hk. Yardım.

[hilmitaranci]

Merhabalar,

Ekli dosyada kendimce yapmaya çalıştığım bir bütçe programı var.

Büyük bir ihtimalle kodları görünce biraz gülecek sinizdir
Elimizden anca bu kadarı geldi.

index sayfasında bulunan verileri grup sayfasına sıralamaya çalışıyorum.

tüm satırlar ve sütunlar dolu olunca her hangi bir problem çıkmıyor.

Ancak boş hücreler işin içine girince grup sayfasında bir dünya boşluk oluyor.

% değeri boş olan hücreleri bir türlü dışarı atamadım.


Bir yol yordam göstere bilirseniz çok sevinirim.


http://www.dosya.tc/server6/u6i1uw/makrolu_butce.xls.html

 

[Ziynettin]

Merhaba,

Umarım sizi doğru anlamışımdır.
Dosyanız ektedir.

Option Explicit
Sub Liste()
    Dim a(), b(), S1 As Worksheet, s2 As Worksheet
    Dim Son As Long, X As Long, Y As Long, Say As Long
    Dim Veri_say As Long, P As Integer, t As Double
    
    t = Timer
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("index")
    Set s2 = Sheets("grup")
    
    Son = S1.Range("A" & Rows.Count).End(3).Row + 1
    Veri_say = Application.CountA(S1.Range("A2:J" & Son))
    a = S1.Range("A2:J" & Son)
    ReDim b(1 To Veri_say, 1 To 5)

Say = 1
For Y = 1 To 8
    For X = 2 To S1.Cells(Son, 1).End(3).Row
        If a(X - 1, Y + 2) <> "" Then
            b(Say, 1) = Say
            b(Say, 2) = a(X - 1, 1)
            b(Say, 3) = a(X - 1, 2)
            b(Say, 5) = a(X - 1, Y + 2)
            b(Say, 4) = S1.Cells(1, Y + 2)
            Say = Say + 1
        End If
    Next X
Next Y
s2.Range("A2:E" & Rows.Count).ClearContents
If Say > 0 Then
s2.Range("A2").Resize(Say, 5) = b
End If
s2.Select
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & "Süre : " & Format(Timer - t, "0.00"), vbInformation
End Sub

http://www.dosya.tc/server6/7qjxm8/makrolu_butce.rar.html

 

[hilmitaranci]

Merhaba,

Umarım sizi doğru anlamışımdır.
Dosyanız ektedir.

Option Explicit
Sub Liste()
    Dim a(), b(), S1 As Worksheet, s2 As Worksheet
    Dim Son As Long, X As Long, Y As Long, Say As Long
    Dim Veri_say As Long, P As Integer, t As Double
    
    t = Timer
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("index")
    Set s2 = Sheets("grup")
    
    Son = S1.Range("A" & Rows.Count).End(3).Row + 1
    Veri_say = Application.CountA(S1.Range("A2:J" & Son))
    a = S1.Range("A2:J" & Son)
    ReDim b(1 To Veri_say, 1 To 5)

Say = 1
For Y = 1 To 8
    For X = 2 To S1.Cells(Son, 1).End(3).Row
        If a(X - 1, Y + 2) <> "" Then
            b(Say, 1) = Say
            b(Say, 2) = a(X - 1, 1)
            b(Say, 3) = a(X - 1, 2)
            b(Say, 5) = a(X - 1, Y + 2)
            b(Say, 4) = S1.Cells(1, Y + 2)
            Say = Say + 1
        End If
    Next X
Next Y
s2.Range("A2:E" & Rows.Count).ClearContents
If Say > 0 Then
s2.Range("A2").Resize(Say, 5) = b
End If
s2.Select
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır." & vbLf & vbLf & "Süre : " & Format(Timer - t, "0.00"), vbInformation
End Sub

http://www.dosya.tc/server6/7qjxm8/makrolu_butce.rar.html

Ustam ellerine sağlık.

Göndermiş olduğun kod çok işime yaradı ve ne kadar boş bir kod yazdığımı da görmüş oldum.