liste doldurmak

[mersilen]

biraz beyin cimnastiği yapalım
en kısa yoldan macro ile nasıl çözülür?
bu kod başka bir sorunun temel taşı olacak

 

[Orion1]

Dosyanız ektedir.

Sub avatar()
Dim tarih As Date, sat As Long, i As Long, sat2 As Long
Dim j As Byte, k As Long, sut As Byte
Application.ScreenUpdating = False
Range("G6:J65536").ClearContents
sat2 = Cells(65536, "A").End(xlUp).Row
For j = 2 To 4
    sut = j + 6
    sat = 6
    tarih = DateSerial(2009, 1, 1)
    For i = 6 To sat2
        If Cells(i, j).Value > 0 Then
            For k = 1 To Cells(i, j).Value
                Cells(sat, "G").Value = tarih
                Cells(sat, sut).Value = Cells(i, "A").Value
                tarih = tarih + 1
                sat = sat + 1
            Next k
        End If
    Next i
Next j
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[mersilen]

evren hocam ilginize tşk
yalnız tabloda her satırda karakterler sadece 1 defa yer almalı; çünkü kişi ancak bir yerde olabilir
onuda ekleyebilir misiniz?


koda bir target eklemesi yaptım
sorun olmaz herhalde
daha sonra sizin geliştirdiğiniz kodu kendi çalışma listeme uyarlamaya çalışacağım

http://www.excel.web.tr/showthread.php?t=83654



Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A1]) Is Nothing Then Exit Sub
Dim tarih As Date, sat As Long, i As Long, sat2 As Long
Dim j As Byte, k As Long, sut As Byte
Application.ScreenUpdating = False
Range("G6:J65536").ClearContents
sat2 = Cells(65536, "A").End(xlUp).Row
For j = 2 To 4
sut = j + 6
sat = 6
tarih = DateSerial(2009, 1, 1)
For i = 6 To sat2
If Cells(i, j).Value > 0 Then
For k = 1 To Cells(i, j).Value
Cells(sat, "G").Value = tarih
Cells(sat, sut).Value = Cells(i, "A").Value
tarih = tarih + 1
sat = sat + 1
Next k
End If
Next i
Next j
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[Orion1]

evren hocam ilginize tşk
yalnız tabloda her satırda karakterler sadece 1 defa yer almalı; çünkü kişi ancak bir yerde olabilir
onuda ekleyebilir misiniz?

Dosyanız ektedir.

Sub avatar()
Dim tarih As Date, sat As Long, i As Long, sat2 As Long
Dim j As Byte, k As Long, sut As Byte
Application.ScreenUpdating = False
Range("G6:J65536").ClearContents
sat2 = Cells(65536, "A").End(xlUp).Row
For j = 2 To 4
    sut = j + 6
    sat = 6
    tarih = DateSerial(2009, 1, 1)
    For i = 6 To sat2
        If Cells(i, j).Value > 0 Then
            For k = 1 To Cells(i, j).Value
                If WorksheetFunction.CountIf(Range(Cells(sat, "H"), _
                Cells(sat, sut)), Cells(i, "A").Value) = 0 Then
                    Cells(sat, "G").Value = tarih
                    Cells(sat, sut).Value = Cells(i, "A").Value
                    tarih = tarih + 1
                    sat = sat + 1
                End If
            Next k
        End If
    Next i
Next j
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[erkaan]

slm

selam
öğrenmek istediğim bir konu var ama yazdığım yer hatalı ise ilk kullandığım için bağışlayın
işim gereği exeli bayağı kullanıyorum
fakat işin uzmanı gibi
değil.
sorunum exel de listelediğim isimlere denk gelen ve (D de olan klasörleri makro yardımı ile bulup köprü kurması.
fakat bunu aktif olan hücrede ki isme denk gelen klasörü bulmasını istiyorum. ben amatörce uğraştım ama başaramadım yardımcı olursanız sevinirim

 

[Orion1]

selam
öğrenmek istediğim bir konu var ama yazdığım yer hatalı ise ilk kullandığım için bağışlayın
işim gereği exeli bayağı kullanıyorum
fakat işin uzmanı gibi
değil.
sorunum exel de listelediğim isimlere denk gelen ve (D de olan klasörleri makro yardımı ile bulup köprü kurması.
fakat bunu aktif olan hücrede ki isme denk gelen klasörü bulmasını istiyorum. ben amatörce uğraştım ama başaramadım yardımcı olursanız sevinirim

Yeni bir başlık açarak sorunuzu orada sorunuz.
Sorunuzun bu konu ile ilgisi yoktur.

 

[mersilen]

Evren hocam

veri 2 ve 3 de sütunlar tam dolmuyor

 

[Orion1]

Evren hocam

veri 2 ve 3 de sütunlar tam dolmuyor

Değişiklik yaptım.İstenen sayıda ayni satırda olmama koşulu gözeterk veri dolduruyor.Ama ayni satıra denk gelirse dolayısı ile arada boşluklar oluyor,mecburen.

Sub avatar()
Dim tarih As Date, sat As Long, i As Long, sat2 As Long
Dim j As Byte, k As Long, sut As Byte
Application.ScreenUpdating = False
Range("G6:J65536").ClearContents
sat2 = Cells(65536, "A").End(xlUp).Row
For j = 2 To 4
    sut = j + 6
    sat = 6
    tarih = DateSerial(2009, 1, 1)
    For i = 6 To sat2
        If Cells(i, j).Value > 0 Then
            tekrar = 0
            Do While tekrar < Cells(i, j).Value
                If WorksheetFunction.CountIf(Range(Cells(sat, "H"), _
                Cells(sat, sut)), Cells(i, "A").Value) = 0 Then
                    Cells(sat, sut).Value = Cells(i, "A").Value
                    tekrar = tekrar + 1
                End If
                Cells(sat, "G").Value = tarih
                tarih = tarih + 1
                sat = sat + 1
            Loop
        End If
    Next i
Next j
Application.ScreenUpdating = True
MsgBox "İşlem Tamamdır." & "evrengizlen@hotmail.com", _
vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[mersilen]

evren hocam tekrar teşekkür

yazdıklarınızı inceliyorum
takıldığım yer olursa tekrar tekrar sorabilirim değil mi?

 

[Orion1]

evren hocam tekrar teşekkür

yazdıklarınızı inceliyorum
takıldığım yer olursa tekrar tekrar sorabilirim değil mi?

Rica ederim.
İyi çalışmalar.