makroda düzenleme

[igultekin2000]

iyi günler; kullanmakta olduğum makroda biraz revizyon yapılabilirse işlemleri daha pratik yapma imkanım olacak. makro çalıştığında açılan sütunların sabitlenmesine çalışıyorum.

Sub hesaplari_kaydir()
   'Oluşturulan sonuçlar siliniyor.
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
   Range(Cells(1, 11), Cells(sonsatir, sonsutun)).Clear
   
   '600 olmayan hesaplar için kolonlar oluşturuluyor
   For i = 2 To sonsatir
     hesap3 = Left(Cells(i, 1).Value, 3)
     hesap = Cells(i, 1).Value
     If hesap3 <> "600" Then
        sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
        buldu = False
        For j = 11 To sonsutun
           bilgi = Cells(1, j).Value
           If bilgi = hesap Then
              buldu = True
              Exit For
           End If
        Next j
        If buldu = False Then
           Cells(1, sonsutun).Value = hesap
        End If
     End If
   Next i
   sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column
   
   '600 olmayan hesaplara tutarlar yazılıyor
   For i = 2 To sonsatir
     hesap3 = Left(Cells(i, 1).Value, 3)
     hesap = Cells(i, 1).Value
     tutar = 0
     If Cells(i, "C").Value > 0 Then tutar = Cells(i, "C").Value Else tutar = Cells(i, "D").Value
     
     If hesap3 = "600" Then
        satir = i
     Else
        For j = 8 To sonsutun
           bilgi = Cells(1, j).Value
           If bilgi = hesap Then
              Cells(satir, j).Value = tutar
              Exit For
           End If
        Next j
     End If
   Next i
   
   '600 olmayan hesaplar siliniyor
   For i = sonsatir To 2 Step -1
     hesap3 = Left(Cells(i, 1).Value, 3)
     If hesap3 <> "600" Then
       Rows(i).Delete
     End If
   Next i
     
End Sub

 

[kanunsuz58]

arkadaşlar merhaba bu forumda kesin bulursun dediler, benim birşeye ihtiyacım 4 takım olması kaydıyla puan durumu prrogram var mı acaba ?

 

[YUSUF44]

arkadaşlar merhaba bu forumda kesin bulursun dediler, benim birşeye ihtiyacım 4 takım olması kaydıyla puan durumu prrogram var mı acaba ?

Şu konuyu bir inceleyin, belki işinize yarar:

http://www.excel.web.tr/f14/kazanan-ki-iye-3-puan-deoil-2-puan-t155581.html

Ayrıca forumda "fikstür" kelimesini aratmanızı öneririm.

Bir de eğer soracağınız soru burda olduğu gibi başlıkla ilgili değilse yeni bir başlık açarak sormanız iyi olur.

 

[igultekin2000]

değer aktarma

iyi günler; ufak bir revizyonla daha anlaşılır hale getirdim ama kodun düzeltilmesinde yardıma ihtiyacım var. A sütunundaki verilere ilişkin aktarım yaparken kodun tamamı değilde soldan ilk üç değerine göre işlem yapmasını sağlamak istiyorum. Teşekkürler

Sub hesaplari_kaydir()
   'Oluşturulan sonuçlar siliniyor.
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
  
   '600 olmayan hesaplara tutarlar yazılıyor
   For i = 2 To sonsatir
     hesap3 = Left(Cells(i, 1).Value, 3)
     hesap = Cells(i, 1).Value
     tutar = 0
     If Cells(i, "C").Value > 0 Then tutar = Cells(i, "C").Value Else tutar = Cells(i, "D").Value
     
     If hesap3 = "600" Then
        satir = i
     Else
        For j = 11 To sonsutun
           bilgi = Cells(1, j).Value
           If bilgi = hesap Then
              Cells(satir, j).Value = tutar
              Exit For
           End If
        Next j
     End If
   Next i
   
   '600 olmayan hesaplar siliniyor
   For i = sonsatir To 2 Step -1
     hesap3 = Left(Cells(i, 1).Value, 3)
     If hesap3 <> "600" Then
       Rows(i).Delete
     End If
   Next i
     
End Sub

 

[Asri]

Tam anlamadım ama aşağıdaki şekilde deneyiniz.

Dim bilgi As String

Sub hesaplari_kaydir()
   'Oluşturulan sonuçlar siliniyor.
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
  
   '600 olmayan hesaplara tutarlar yazılıyor
   For i = 2 To sonsatir
     hesap3 = Left(Cells(i, 1).Value, 3)
     hesap = Cells(i, 1).Value
     tutar = 0
     If Cells(i, "C").Value > 0 Then tutar = Cells(i, "C").Value Else tutar = Cells(i, "D").Value
     
     If hesap3 = "600" Then
        satir = i
     Else
        For j = 11 To sonsutun
           bilgi = Cells(1, j).Value
           If bilgi = Left(hesap, 3) Then
              Cells(satir, j).Value = tutar
              Exit For
           End If
        Next j
     End If
   Next i
   
   '600 olmayan hesaplar siliniyor
   For i = sonsatir To 2 Step -1
     hesap3 = Left(Cells(i, 1).Value, 3)
     If hesap3 <> "600" Then
       Rows(i).Delete
     End If
   Next i
     
End Sub

 

[igultekin2000]

işlem sorunsuz

Tam anlamadım ama aşağıdaki şekilde deneyiniz.

Dim bilgi As String

Sub hesaplari_kaydir()
   'Oluşturulan sonuçlar siliniyor.
   sonsatir = Cells(Rows.Count, "A").End(3).Row
   sonsutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
  
   '600 olmayan hesaplara tutarlar yazılıyor
   For i = 2 To sonsatir
     hesap3 = Left(Cells(i, 1).Value, 3)
     hesap = Cells(i, 1).Value
     tutar = 0
     If Cells(i, "C").Value > 0 Then tutar = Cells(i, "C").Value Else tutar = Cells(i, "D").Value
     
     If hesap3 = "600" Then
        satir = i
     Else
        For j = 11 To sonsutun
           bilgi = Cells(1, j).Value
           If bilgi = Left(hesap, 3) Then
              Cells(satir, j).Value = tutar
              Exit For
           End If
        Next j
     End If
   Next i
   
   '600 olmayan hesaplar siliniyor
   For i = sonsatir To 2 Step -1
     hesap3 = Left(Cells(i, 1).Value, 3)
     If hesap3 <> "600" Then
       Rows(i).Delete
     End If
   Next i
     
End Sub

teşekkürler, istediğim gibi olmuş, elinize sağlık.