Rapor Alma

[igultekin2000]

iyi akşamlar; sonuçlanan dosyayı yorumlamak için yardıma ihtiyacım var. Son halde I sütununda " x " işaretlenmeyen verilerin ilgili sayfalara aktarılmasını yapmak istiyorum. Şöyle ki 101 - 103 -321 - 103 ile başlayan satırların ilgili çalışma sayfalarına aktarılması. Teşekkürler.

 

[YUSUF44]

Aşağıdaki kodu bir modüle kopyalayıp deneyiniz.

Sub aktar()
Set s1 = Sheets("stok")
son = s1.Cells(Rows.Count, "C").End(3).Row
For i = 2 To son
    If s1.Cells(i, "I") <> "x" Then
        For j = 1 To Sheets.Count
            If Sheets(j).Name = Left(s1.Cells(i, "C"), 3) Then
                kod = "var"
                j = Sheets.Count
            Else
                kod = "yok"
            End If
        Next
        If kod = "yok" Then
            Sheets.Add
            s1.[A1:G1].Copy ActiveSheet.[A1]
            ActiveSheet.Name = Left(s1.Cells(i, "C"), 3)
        End If
        For sayfa = 1 To Sheets.Count
            If Sheets(sayfa).Name = Left(s1.Cells(i, "C"), 3) Then
                yeni = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row + 1
                s1.Range("A" & i & ":G" & i).Copy Sheets(sayfa).Cells(yeni, "A")
                sayfa = Sheets.Count
            End If
        Next
    End If
Next
End Sub

 

[askm]

Sub askm()
Dim s As Worksheet
Set s = Sheets("stok")
Dim son, son2 As Long
son = s.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To son
    If s.Cells(i, 9) = "" Then
        SayfaAdi = CStr(Left(s.Cells(i, 3), 3))
        son2 = Sheets(SayfaAdi).Range("C" & Rows.Count).End(xlUp).Row + 1
        s.Range(s.Cells(i, 1), s.Cells(i, 7)).Copy Sheets(SayfaAdi).Cells(son2, 1)
    End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

 

[igultekin2000]

sorunsuz çalışıyor

Aşağıdaki kodu bir modüle kopyalayıp deneyiniz.

Sub aktar()
Set s1 = Sheets("stok")
son = s1.Cells(Rows.Count, "C").End(3).Row
For i = 2 To son
    If s1.Cells(i, "I") <> "x" Then
        For j = 1 To Sheets.Count
            If Sheets(j).Name = Left(s1.Cells(i, "C"), 3) Then
                kod = "var"
                j = Sheets.Count
            Else
                kod = "yok"
            End If
        Next
        If kod = "yok" Then
            Sheets.Add
            s1.[A1:G1].Copy ActiveSheet.[A1]
            ActiveSheet.Name = Left(s1.Cells(i, "C"), 3)
        End If
        For sayfa = 1 To Sheets.Count
            If Sheets(sayfa).Name = Left(s1.Cells(i, "C"), 3) Then
                yeni = Sheets(sayfa).Cells(Rows.Count, "A").End(3).Row + 1
                s1.Range("A" & i & ":G" & i).Copy Sheets(sayfa).Cells(yeni, "A")
                sayfa = Sheets.Count
            End If
        Next
    End If
Next
End Sub

Teşekkür ederim, kod sorunsuz çalışıyor. iyi akşamlar

 

[igultekin2000]

sorunsuz çalışıyor

Sub askm()
Dim s As Worksheet
Set s = Sheets("stok")
Dim son, son2 As Long
son = s.Range("C" & Rows.Count).End(xlUp).Row
Application.ScreenUpdating = False
For i = 2 To son
    If s.Cells(i, 9) = "" Then
        SayfaAdi = CStr(Left(s.Cells(i, 3), 3))
        son2 = Sheets(SayfaAdi).Range("C" & Rows.Count).End(xlUp).Row + 1
        s.Range(s.Cells(i, 1), s.Cells(i, 7)).Copy Sheets(SayfaAdi).Cells(son2, 1)
    End If
Next i
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "İşlem tamam...", vbInformation, "ASKM"
End Sub

teşekkürler, kod sorunsuz çalışıyor, hayırlı akşamlar.

 

[askm]

Rica ederim. Hayırlı akşamlar.