Veri aktarımı yaparken veri düzenini değiştirmek ve yeni tablo yaratmak

[Deniz_Excel]

Herkese saygılar, sevgiler,

Ne yapmak istediğimi linkteki excel dosyasını indirdiğinizde direk anlayabilirsiniz.
Sheet1 de bulunan benim manual doldurduğum güncel tablomdur. Yazmak istediğim makro ile sheet2 deki tablonun otomatik olarak oluşmasını istiyorum.

Burada Sheet1 deki her aracım için birden fazla part ımız olduğundan part sayısı kadar satır oluşturup verileri tekrar tekrar her satıra yazdırmış oluyoruz.

Kod konusunda yardımlarınızı bekliyorum.

Link:

Formatchange.xlsx dosyasını indir - download

Formatchange.xlsx dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

teşekkürler

 

[YUSUF44]

Aşağıdaki makroyu bir modüle kopyalayıp deneyin:

Sub parts()
Set s1 = Sheets("sheet1")
Set s2 = Sheets("sheet2")
sonF = s1.Cells(Rows.Count, "F").End(3).Row
eski = s2.Cells(Rows.Count, "A").End(3).Row
If eski > 1 Then s2.Range("A2:F" & eski).Clear
For arac = 2 To sonF
    partiler = Split(s1.Cells(arac, "F"), Chr(10))
    say = UBound(partiler)
    bas = s2.Cells(Rows.Count, "A").End(3).Row + 1
    For parti = 0 To say
        yeni = s2.Cells(Rows.Count, "A").End(3).Row + 1
        s2.Cells(yeni, "A") = s1.Cells(arac, "C")
        s2.Cells(yeni, "B") = s1.Cells(arac, "A")
        s2.Cells(yeni, "C") = s1.Cells(arac, "D")
        s2.Cells(yeni, "D") = "OK"
        s2.Cells(yeni, "E") = Date
        s2.Cells(yeni, "F") = partiler(parti)
    Next
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With s2.Range("A" & bas & ":F" & yeni).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlHairline
    End With
    With s2.Range("A" & bas & ":F" & yeni).Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
Next
With s2.Range("A2:F" & yeni)
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlBottom
    .WrapText = False
    .Orientation = 0
    .AddIndent = False
    .IndentLevel = 0
    .ShrinkToFit = False
    .ReadingOrder = xlContext
    .MergeCells = False
End With
s2.Activate
MsgBox "İşlem Tamamlandı!"
End Sub

 

[muygun]

Merhaba;
Alternatif:
Eki deneyin.
İyi çalışmalar.

Link:
https://s5.dosya.tc/server6/fq9wdb/Deniz_Excel-Formatchange.zip.html

 

[Deniz_Excel]

YUSUF44 teşekkürler bir kaç test yaptım şuan hiç bir problem görünmüyor.
muygun size de aynı şekilde teşekkür ederim.

Aynı uygulamayı bir de ADO yöntemi ile nasıl yaparız?