karışık tabloyu düzenli forma taşıma

[sedatkilci]

Merhabalar,

Ekli dosyada hftbrç sheetinde programdan çektiğimizde sabit olarak karışık gelen bir tabloyu sayfa4 shettindeki forma taşımak istiyorum.
Yardımcı olabilir misiniz?

Selamlar...

 

[Ömer BARAN]

Merhaba.

-- Belgeniz açıkken, ALT+F11 tuşlarına basın,
-- Açılan VBA ekranının MENÜ çubuğundan INSERT -> MODULEyi seçin,
-- Sağdaki boş alana aşağıdaki kod blokunu yapıştırın.
-- İmlecin, kod'un ilk satırında olmasını sağlayın ve F5 tuşuna basın.
.

[B][COLOR="red"]Sub TOPARLA()[/COLOR][/B]
Sheets("[B][COLOR="Blue"]hftbrc[/COLOR][/B]").Copy After:=Sheets(Sheets.Count)
Set k = Sheets("[B][COLOR="blue"]hftbrc[/COLOR][/B] (2)")
sonsat = k.Cells.SpecialCells(xlCellTypeLastCell).Row
sonsut = k.Cells.SpecialCells(xlCellTypeLastCell).Column

For sut = sonsut To 1 Step -1
    If k.Cells(Rows.Count, sut).End(3).Row = 1 Then k.Columns(sut).Delete Shift:=xlToLeft
Next
For sat = sonsat To 1 Step -1
    If k.Cells(sat, Columns.Count).End(xlToLeft).Column = 1 Then k.Rows(sat).Delete Shift:=xlUp
Next
For bir = sonsat To 1 Step -1
    If k.Cells(1, bir) = "" Then k.Columns(bir).Delete Shift:=xlToLeft
Next
For satt = 2 To k.Cells(Rows.Count, 2).End(3).Row
    If Not IsNumeric(k.Cells(satt, 2)) Then
        k.Rows(satt & ":" & satt).Insert Shift:=xlDown
        k.Rows(satt + 2 & ":" & satt + 2).Insert Shift:=xlDown
        satt = satt + 2
    End If
Next
k.Cells.EntireColumn.AutoFit
MsgBox "İşlem tamamlandı.", vbInformation, "..:: Ömer BARAN ::.."
[B][COLOR="Red"]End Sub[/COLOR][/B]

 

[sedatkilci]

İlginiz için çok teşekkür ederim. modül değil de formül önerme imkanınız olur mu?

Selamlar...