Farklı formatlı verileri grup olarak listeleme

T

tekirdagli_0059

Katılım
27 Nisan 2012
Mesajlar
21
Excel Vers. ve Dili
2010-EN
Merhaba, https://www.dosyaupload.com/ryKP yüklemiş olduğum excel Sayfa1'de günlük iş programı var, Sayfa2 de ise kendi içinde gruplanmış ve istemiş olduğum format (önce plaka sonra kullanıcı) olacak şekilde nasıl yapabilirim?
Şimdiden teşekkürler.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

PHP: 
Sub program()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s2.Range("B:D").Clear
sonsut = s1.Cells(5, Columns.Count).End(xlToLeft).Column
sonsat = s1.Cells(Rows.Count, "B").End(3).Row
s2.Activate
Application.ScreenUpdating = False
For sut = 3 To sonsut Step 4
    For sat = 6 To sonsat Step 12
        yeni = s2.Cells(Rows.Count, "D").End(3).Row + 1
        s1.Activate
        s1.Range(Cells(sat, sut), Cells(sat + 7, sut)).Copy
        s2.Activate
        s2.Cells(yeni, "C").Select
        ActiveSheet.Paste
        s1.Activate
        s1.Range(Cells(sat, sut + 1), Cells(sat + 7, sut + 1)).Copy
        s2.Activate
        s2.Cells(yeni, "B").Select
        ActiveSheet.Paste
        s1.Activate
        s1.Range(Cells(sat, sut + 2), Cells(sat + 7, sut + 2)).Copy
        s2.Activate
        s2.Cells(yeni, "D").Select
        ActiveSheet.Paste
    Next
Next

s2.Cells.EntireRow.AutoFit
s2.Cells.EntireColumn.AutoFit
Application.CutCopyMode = False

son = s2.Cells(Rows.Count, "D").End(3).Row

For i = son To 2 Step -1
    If s2.Cells(i, "D") = "Ekip Sorumlusu" Or s2.Cells(i, "C") = "" Then
        s2.Range("B" & i & ":D" & i).Delete
    End If
Next

s2.Sort.SortFields.Clear
s2.Sort.SortFields.Add Key:=Range("D2:D" & son) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
    "Kamyon,Tır,Pick-Up,Silindir,Ekskavatör,JCB", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa2").Sort
    .SetRange Range("B2:D" & son)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

enson = s2.Cells(Rows.Count, "D").End(3).Row

For j = enson To 2 Step -1
    If s2.Cells(j, "D") <> s2.Cells(j - 1, "D") Then
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
        s2.Range("B" & j & ":C" & j).Merge
        s2.Range("B" & j & ":C" & j).Font.Bold = True
        s2.Range("B" & j & ":C" & j).HorizontalAlignment = xlCenter
        s2.Cells(j, "B") = s2.Cells(j + 1, "D")
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
End If
Next

s2.Range("B:D").VerticalAlignment = xlCenter
s2.Columns("D").Delete
nihai = s2.Cells(Rows.Count, "C").End(3).Row
s2.Range("B" & nihai + 1 & ":D" & nihai + 1).Delete

With s2.Range("B2:C" & nihai)
    .Interior.Color = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For k = 2 To nihai
    If s2.Cells(k, "B") = "" Then
        s2.Cells(k + 1, "B").Select
        Selection.CurrentRegion.Select
        With Selection
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).ColorIndex = 0
            .Borders(xlEdgeTop).ColorIndex = 0
            .Borders(xlEdgeBottom).ColorIndex = 0
            .Borders(xlEdgeRight).ColorIndex = 0
            .Borders(xlInsideVertical).ColorIndex = 0
            .Borders(xlInsideHorizontal).ColorIndex = 0
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    End If
Next

[A1].Select
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"

End Sub
 
T

tekirdagli_0059

Katılım
27 Nisan 2012
Mesajlar
21
Excel Vers. ve Dili
2010-EN
YUSUF44' Alıntı:
Aşağıdaki makroyu bir modüle kopyalayıp deneyiniz:

PHP: 
Sub program()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s2.Range("B:D").Clear
sonsut = s1.Cells(5, Columns.Count).End(xlToLeft).Column
sonsat = s1.Cells(Rows.Count, "B").End(3).Row
s2.Activate
Application.ScreenUpdating = False
For sut = 3 To sonsut Step 4
    For sat = 6 To sonsat Step 12
        yeni = s2.Cells(Rows.Count, "D").End(3).Row + 1
        s1.Activate
        s1.Range(Cells(sat, sut), Cells(sat + 7, sut)).Copy
        s2.Activate
        s2.Cells(yeni, "C").Select
        ActiveSheet.Paste
        s1.Activate
        s1.Range(Cells(sat, sut + 1), Cells(sat + 7, sut + 1)).Copy
        s2.Activate
        s2.Cells(yeni, "B").Select
        ActiveSheet.Paste
        s1.Activate
        s1.Range(Cells(sat, sut + 2), Cells(sat + 7, sut + 2)).Copy
        s2.Activate
        s2.Cells(yeni, "D").Select
        ActiveSheet.Paste
    Next
Next

s2.Cells.EntireRow.AutoFit
s2.Cells.EntireColumn.AutoFit
Application.CutCopyMode = False

son = s2.Cells(Rows.Count, "D").End(3).Row

For i = son To 2 Step -1
    If s2.Cells(i, "D") = "Ekip Sorumlusu" Or s2.Cells(i, "C") = "" Then
        s2.Range("B" & i & ":D" & i).Delete
    End If
Next

s2.Sort.SortFields.Clear
s2.Sort.SortFields.Add Key:=Range("D2:D" & son) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
    "Kamyon,Tır,Pick-Up,Silindir,Ekskavatör,JCB", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa2").Sort
    .SetRange Range("B2:D" & son)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

enson = s2.Cells(Rows.Count, "D").End(3).Row

For j = enson To 2 Step -1
    If s2.Cells(j, "D") <> s2.Cells(j - 1, "D") Then
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
        s2.Range("B" & j & ":C" & j).Merge
        s2.Range("B" & j & ":C" & j).Font.Bold = True
        s2.Range("B" & j & ":C" & j).HorizontalAlignment = xlCenter
        s2.Cells(j, "B") = s2.Cells(j + 1, "D")
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
End If
Next

s2.Range("B:D").VerticalAlignment = xlCenter
s2.Columns("D").Delete
nihai = s2.Cells(Rows.Count, "C").End(3).Row
s2.Range("B" & nihai + 1 & ":D" & nihai + 1).Delete

With s2.Range("B2:C" & nihai)
    .Interior.Color = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For k = 2 To nihai
    If s2.Cells(k, "B") = "" Then
        s2.Cells(k + 1, "B").Select
        Selection.CurrentRegion.Select
        With Selection
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).ColorIndex = 0
            .Borders(xlEdgeTop).ColorIndex = 0
            .Borders(xlEdgeBottom).ColorIndex = 0
            .Borders(xlEdgeRight).ColorIndex = 0
            .Borders(xlInsideVertical).ColorIndex = 0
            .Borders(xlInsideHorizontal).ColorIndex = 0
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    End If
Next

[A1].Select
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"

End Sub
Genişletmek için tıkla ...
YUSUF44 emeğine, ellerine sağlık, tam istediğim gibi fakat tek eksiği (örnek listede) listenin 2.kısmındaki verileri (ekip Sorumlusu olarak örneklediğim) listeye dahil etmiyor. Kendi listemde de (3 sayfa ) ilk hücrelerdeki (B-E arası) sonraki sütunlardaki değerleri almıyor.B-E arasındaki değerleri de eksik listeliyor. (listemde 78 kişi var, makro maksimum 43-47 arası getiriyor.)
teşekkürler.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Örnek dosyanızda Ekip sorumlusunu ikinci sayfaya aktarmamıştınız, plakası da yok zaten, ben de gerek yok demek ki diye düşünmüştüm.

Verdiğim makro Sayfa1'in B sütunundaki son dolu hücrenin satır numarasına ve 5. satırdaki en son dolu hücrenin sütun numarasına göre işlem yapar. Eksik veri alıyor diyorsanız dosya yapınız ilk verdiğiniz örnek dosyadan farklıdır.

Dosyayı hatalı olduğu haliyle yüklerseniz incelemeye çalışırız.
 
T

tekirdagli_0059

Katılım
27 Nisan 2012
Mesajlar
21
Excel Vers. ve Dili
2010-EN
Tekrar Merhaba,
dosyanın 1.sayfasını güncelledim ve https://www.dosyaupload.com/f0ir adresine yükledim, 1.sayfadan sonra 5 satır açıklama alanı var, bu alandan sonra 2 sayfa verileri var, aynı şekilde 5 satır açıklama alanı var ve 3.sayfa verileri var. 1.sayfayı eksiksiz çıkartmamamız durumunda tüm sayfada sorunsuz çalışacağını düşünüyorum.

teşekkürler.
 
YUSUF44

YUSUF44

Destek Ekibi
Destek Ekibi
Katılım
4 Ocak 2006
Mesajlar
12,084
Excel Vers. ve Dili
İş : Ofis 365 - Türkçe
Ev: Ofis 365 - Türkçe
Aşağıdaki gibi deneyin:

PHP: 
Sub program()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s2.Range("B:D").Clear
sonsut = s1.Cells(5, Columns.Count).End(xlToLeft).Column
sonsat = s1.Cells(Rows.Count, "B").End(3).Row
For a = 2 To sonsut Step 4
    dolu = Cells(Rows.Count, a).End(3).Row
    If dolu > sonsat Then sonsat = dolu
Next
        

s2.Activate
Application.ScreenUpdating = False
For sut = 2 To sonsut Step 4
    For sat = 6 To sonsat
        If IsNumeric(s1.Cells(sat, sut)) = True Then
            yeni = s2.Cells(Rows.Count, "D").End(3).Row + 1
            s2.Cells(yeni, "B") = s1.Cells(sat, sut + 2)
            s2.Cells(yeni, "C") = s1.Cells(sat, sut + 1)
            s2.Cells(yeni, "D") = s1.Cells(sat, sut + 3)
        End If
    Next
Next

s2.Cells.EntireRow.AutoFit
s2.Cells.EntireColumn.AutoFit
Application.CutCopyMode = False

son = s2.Cells(Rows.Count, "D").End(3).Row

For i = son To 2 Step -1
    If s2.Cells(i, "C") = "" Then
        s2.Range("B" & i & ":D" & i).Delete
    End If
Next

s2.Sort.SortFields.Clear
s2.Sort.SortFields.Add Key:=Range("D2:D" & son) _
    , SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
    "Ekip Sorumlusu,Kamyon,Tır,Pick-Up,Silindir,Ekskavatör,JCB", DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sayfa2").Sort
    .SetRange Range("B2:D" & son)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

enson = s2.Cells(Rows.Count, "D").End(3).Row

For j = enson To 2 Step -1
    If s2.Cells(j, "D") <> s2.Cells(j - 1, "D") Then
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
        s2.Range("B" & j & ":C" & j).Merge
        s2.Range("B" & j & ":C" & j).Font.Bold = True
        s2.Range("B" & j & ":C" & j).HorizontalAlignment = xlCenter
        s2.Cells(j, "B") = s2.Cells(j + 1, "D")
        s2.Range("B" & j & ":D" & j).Insert shift:=xlDown
End If
Next

s2.Range("B:D").VerticalAlignment = xlCenter
s2.Columns("D").Delete
nihai = s2.Cells(Rows.Count, "C").End(3).Row
s2.Range("B" & nihai + 1 & ":D" & nihai + 1).Delete

With s2.Range("B2:C" & nihai)
    .Interior.Color = xlNone
    .Borders(xlDiagonalDown).LineStyle = xlNone
    .Borders(xlDiagonalUp).LineStyle = xlNone
    .Borders(xlEdgeLeft).LineStyle = xlNone
    .Borders(xlEdgeTop).LineStyle = xlNone
    .Borders(xlEdgeBottom).LineStyle = xlNone
    .Borders(xlEdgeRight).LineStyle = xlNone
    .Borders(xlInsideVertical).LineStyle = xlNone
    .Borders(xlInsideHorizontal).LineStyle = xlNone
End With

For k = 2 To nihai
    If s2.Cells(k, "B") = "" Then
        s2.Cells(k + 1, "B").Select
        Selection.CurrentRegion.Select
        With Selection
            .Borders(xlDiagonalDown).LineStyle = xlNone
            .Borders(xlDiagonalUp).LineStyle = xlNone
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlInsideHorizontal).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).ColorIndex = 0
            .Borders(xlEdgeTop).ColorIndex = 0
            .Borders(xlEdgeBottom).ColorIndex = 0
            .Borders(xlEdgeRight).ColorIndex = 0
            .Borders(xlInsideVertical).ColorIndex = 0
            .Borders(xlInsideHorizontal).ColorIndex = 0
            .Borders(xlEdgeLeft).Weight = xlThin
            .Borders(xlEdgeTop).Weight = xlThin
            .Borders(xlEdgeBottom).Weight = xlThin
            .Borders(xlEdgeRight).Weight = xlThin
            .Borders(xlInsideVertical).Weight = xlHairline
            .Borders(xlInsideHorizontal).Weight = xlHairline
        End With
    End If
Next

[A1].Select
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı"

End Sub
Bundan sonraki sorularınızda harcadığımız vakit ve emeğin boşa gitmemesi için örnek dosyanızın asıl dosyanızla aynı yapıda olmasına dikkat edin lütfen.
 
T

tekirdagli_0059

Katılım
27 Nisan 2012
Mesajlar
21
Excel Vers. ve Dili
2010-EN
Emeğiniz ve uyarınız için teşekkürler YUSUF44, tam istediğim gibi olmuş
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst