Verileri istenen düzene sokmak

[tchsyn]

Arkadaşlar Sheet1 de anadosyam var. Ben VBA ile makro yazmaya çalışıp Sheet2 deki hale getirmeye çalıştım ama birtürlü beceremedim
Yardım lütfen.

 

[dEdE]

Merhaba,
Dosyanız ektedir.

Sub Aktar()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")

s2.Range("B3:H" & Rows.Count).ClearContents
For k = 1 To 2
    If k = 1 Then q = 6 Else q = 9
    For i = 8 To s1.Range("B" & Rows.Count).End(3).Row
        ss = s2.Range("B" & Rows.Count).End(3).Row + 1
        s2.Range("B" & ss & ":E" & ss).Value = s1.Range("B" & i & ":E" & i).Value
        s2.Cells(ss, 6).Value = s1.Cells(5, q).Value
        s2.Range("G" & ss & ":H" & ss).Value = s1.Range(s1.Cells(i, q), s1.Cells(i, q + 1)).Value
    Next i
Next
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[tchsyn]

Dede bey cok teşekkurler. şoyle bır sorun var. ornek dosyada tarife sutununda %25 yazıyorsa. baslık-1 kısmı yerine indirimli yazdırmamız mumkunmu? ama sadece başlık-1 ıcın gecerlı olmalı..

 

[dEdE]

Merhaba,
Aşağıdaki kodu dener misiniz?

Sub Aktar()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")

s2.Range("B3:H" & Rows.Count).ClearContents
For k = 1 To 2
    If k = 1 Then q = 6 Else q = 9
    For i = 8 To s1.Range("B" & Rows.Count).End(3).Row
        ss = s2.Range("B" & Rows.Count).End(3).Row + 1
        s2.Range("B" & ss & ":E" & ss).Value = s1.Range("B" & i & ":E" & i).Value
        If q = 6 And s1.Cells(i, 11).Value = "0,25" Then
            s2.Cells(ss, 6).Value = "İndirimli"
            Else
            s2.Cells(ss, 6).Value = s1.Cells(5, q).Value
        End If
        s2.Range("G" & ss & ":H" & ss).Value = s1.Range(s1.Cells(i, q), s1.Cells(i, q + 1)).Value
    Next i
Next
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[tchsyn]

elleriniz dert görmesin. çalıştı teşekkürler

 

[tchsyn]

Verileri düzene sokmak

merhaba daha önceki senaryoya ekteki örnekte ki gibi 3. koşul eklendi. aşağıdaki makro 2 başlık için çalışıyor fakat 3. başlığıda dahil etmek istiyorum.
Sheet1 deki tabloyu Sheet2 deki hale getirmesi konusunda yardım.
---------------------------------------------

Sub Aktar()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")

s2.Range("B3:H" & Rows.Count).ClearContents
For k = 1 To 2
If k = 1 Then q = 6 Else q = 9
For i = 8 To s1.Range("B" & Rows.Count).End(3).Row
ss = s2.Range("B" & Rows.Count).End(3).Row + 1
s2.Range("B" & ss & ":E" & ss).Value = s1.Range("B" & i & ":E" & i).Value
s2.Cells(ss, 6).Value = s1.Cells(5, q).Value
s2.Range("G" & ss & ":H" & ss).Value = s1.Range(s1.Cells(i, q), s1.Cells(i, q + 1)).Value
Next i
Next
End Sub

 

[dEdE]

Merhaba,
Aşağıdaki şekilde dener misiniz?

Sub Aktar()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
q = 3
s2.Range("B3:H" & Rows.Count).ClearContents
For k = 1 To 3
q = q + 3
    For i = 8 To s1.Range("B" & Rows.Count).End(3).Row
        ss = s2.Range("B" & Rows.Count).End(3).Row + 1
        s2.Range("B" & ss & ":E" & ss).Value = s1.Range("B" & i & ":E" & i).Value
        s2.Cells(ss, 6).Value = s1.Cells(5, q).Value
        s2.Range("G" & ss & ":H" & ss).Value = s1.Range(s1.Cells(i, q), s1.Cells(i, q + 1)).Value
    Next i
Next
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub

 

[tchsyn]

dede bey boş olan saatleri alma nasıl diyebiliriz?

 

[dEdE]

dede bey boş olan saatleri alma nasıl diyebiliriz?

Merhaba,
Yanlış anlamadımsa aşağıdaki kod sorununuzu çözeçektir.

Sub Aktar()
Set s1 = Sheets("Sheet1")
Set s2 = Sheets("Sheet2")
q = 3
s2.Range("B3:H" & Rows.Count).ClearContents
For k = 1 To 3
q = q + 3
For i = 8 To s1.Range("B" & Rows.Count).End(3).Row
    ss = s2.Range("B" & Rows.Count).End(3).Row + 1
    If s1.Cells(i, q).Value <> "" Then
        s2.Range("B" & ss & ":E" & ss).Value = s1.Range("B" & i & ":E" & i).Value
        s2.Cells(ss, 6).Value = s1.Cells(5, q).Value
        s2.Range("G" & ss & ":H" & ss).Value = s1.Range(s1.Cells(i, q), s1.Cells(i, q + 1)).Value
    End If
Next i
Next
MsgBox "Aktarma Tamamlandı.", vbInformation, "dEdE " & Application.UserName & "'e Başarılar diler."
End Sub