Birleşik Sütunları Ayırma.

U

universitelio

Katılım
1 Ocak 2024
Mesajlar
65
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019
Merhabalar. Ekte yer alan dosyada 2024 yılına ait dgs kılavuzu yer almaktadır. Bu kılavuzda sol tarafta 2 yıllık bölümlerden mezun olan öğrencilerin gidebilecekleri 4 yıllık bölümler yer almaktadır. Ancak herhangi bir bölümün mezunları her bölüme gidemiyor. Tablolarda görebileceğiniz gibi sol tarafta önlisans bölümleri sağ tarafta da gidilebilecek bölümler var. Ancak benim bu pdf dosyasını da yer alan gibi birleşmiş şekilde değil de bütün bölümlerin ayrı satırlar halinde olması gerekiyor. Mesela ilk satırda yer alan acil bakım teknikerliğinin sağında yer alan bölüm ile tek satırda yer alacak. Sonra ikinci satırda yer alan acil bakım ile sağındaki bölümler ayrı bir satır ile ayrılmaları gerekiyor. Bunu nasıl yapabiliriz acaba?

Ek dosyası
 
N

Necdet

Moderatör
Yönetici
Katılım
4 Haziran 2005
Mesajlar
15,567
Excel Vers. ve Dili
Ofis 365 Türkçe
Merhaba,
Neden excel değil de pdf dosyası eklediniz?
Çözümü excelde istediğinize göre, neden?
 
U

universitelio

Katılım
1 Ocak 2024
Mesajlar
65
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019
Hocalarım @hasankardas hocamızın yüklediği belgeyi altın üyeliğim olmadığı için göremiyorum. Bir hocamız harici siteye yükleyebilir mi rica etsem? Çok acil olmasa böyle bir talepte bulunmazdım.
 
H

hasankardas

Altın Üye
Katılım
14 Ağustos 2006
Mesajlar
483
Excel Vers. ve Dili
Ofis 2021ProPlus TR 64 Bit
Altın Üyelik Bitiş Tarihi
18-01-2027
universitelio' Alıntı:
Hocalarım @hasankardas hocamızın yüklediği belgeyi altın üyeliğim olmadığı için göremiyorum. Bir hocamız harici siteye yükleyebilir mi rica etsem? Çok acil olmasa böyle bir talepte bulunmazdım.
Genişletmek için tıkla ...
excele çevirmiş hali, üzerinde bir işlem yok. biraz işlem yaptırdım fakat eksik. tabloda karışık şekilde dağılım var.. bir mantık kurduramadım..
 
M

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
591
Excel Vers. ve Dili
Office365 TR
SeciliAlanıTabloyaDönüştür makro kodunu yapayzekaya yazdırdım.
Seçili hücre aralığında (5 sütun olacak şekilde) B ve C sütunlarındaki dolu hücre sayılarına göre, bu verileri "TABLO" sayfasına çoğaltarak aktarır.
 
U

universitelio

Katılım
1 Ocak 2024
Mesajlar
65
Excel Vers. ve Dili
Microsoft Office Professional Plus 2019
muratboz06' Alıntı:
SeciliAlanıTabloyaDönüştür makro kodunu yapayzekaya yazdırdım.
Seçili hücre aralığında (5 sütun olacak şekilde) B ve C sütunlarındaki dolu hücre sayılarına göre, bu verileri "TABLO" sayfasına çoğaltarak aktarır.
Genişletmek için tıkla ...
Murat Bey selamlar. Uzun zaman sonra bu dosya ile tekrar işim oldu da. ÖSYM her yıl yeni kılavuz yayımlıyor. Dolayısıyla buradaki veriler de değişiyor. Bu nedenle yeni verileri alabilmek için desteğinize ihtiyacım var. Bana bu dosyanın içerisinde yer alan kodun çalışma mantığını ve bu kodu yeni bir dosyaya nasıl uyarlayabileceğim konusunda destek olursanız gerçekten minnettar olacağım.
 
M

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
591
Excel Vers. ve Dili
Office365 TR
Aşağıdaki kodu Excelde Visual Basic bölümüne (ALT+F11 tuşlarıyla erişim sağlarsınız) yukarda Insert>Module deyip yeni kod sayfası açınız ve aşağıdaki kodları yapıştırınız.

Önce SekilEkleVeMakroAta makrosunu çalıştırınız ve bütün sayfalarda şekilleri oluşturunuz.
Daha sonra her bir sayfada dönüştürmek istediğiniz alanı seçerek sayfada oluşturulan şekile (Tabloya Dönüştür) tıklayınız. İlgili alanlar istediğiniz şekilde dönüştürülecektir.

Kod: 
Sub SeciliAlanıTabloyaDönüştür()
 
    Dim secim As Range
    Set secim = Selection
    
    If secim.Columns.Count <> 5 Then
        MsgBox "Lütfen tam olarak 5 sütun seçin!", vbExclamation, "Uyarı"
        Exit Sub
    End If

    Dim satir As Range
    Dim bSay As Long, cSay As Long
    bSay = 0
    cSay = 0

    For Each satir In secim.Rows
        If Len(satir.Cells(1, 2)) > 1 Then
            bSay = bSay + 1
        End If
        If Len(satir.Cells(1, 3)) > 1 Then
            cSay = cSay + 1
        End If
    Next satir
    
    Dim hedef As Worksheet
    Set hedef = ThisWorkbook.Worksheets("TABLO")
  
  
 
    For i = 1 To bSay
    hedefSonSatir = hedef.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        For j = 1 To cSay
        
            hedef.Cells(hedefSonSatir + j, 1) = secim.Cells(i, 1)
            hedef.Cells(hedefSonSatir + j, 2) = secim.Cells(i, 2)
           ' secim.Range(Cells(j, 3), Cells(cSay, 5)).Copy
           ' hedef.Range("C" & hedefSonSatir + j).PasteSpecial xlPasteValues
        hedef.Cells(hedefSonSatir + j, 3) = secim.Cells(j, 3)
        hedef.Cells(hedefSonSatir + j, 4) = secim.Cells(j, 4)
          hedef.Cells(hedefSonSatir + j, 5) = secim.Cells(j, 5)
        
        Next j
    Next i
    MsgBox "B sütununda dolu satır sayısı: " & bSay & vbCrLf & _
           "C sütununda dolu satır sayısı: " & cSay, vbInformation

End Sub



Sub SekilEkleVeMakroAta()

    Dim ws As Worksheet
    Dim sekil1 As Shape, sekil2 As Shape
    Dim solKenar As Double, ustKenar As Double
    Dim genislik As Double, yukseklik As Double

    ' Şekil boyutu (orta büyüklük)
    genislik = 100
    yukseklik = 40

    For Each ws In ThisWorkbook.Worksheets
        
        ' H10 için konum al ve şekli ekle
        solKenar = ws.Range("H10").Left
        ustKenar = ws.Range("H10").Top
        Set sekil1 = ws.Shapes.AddShape(msoShapeRectangle, solKenar, ustKenar, genislik, yukseklik)
        With sekil1
            .TextFrame2.TextRange.Text = "Tabloya Dönüştür"
            .OnAction = "SeciliAlanıTabloyaDönüştür"
            .Fill.ForeColor.RGB = RGB(91, 155, 213)
            .TextFrame2.TextRange.Font.Size = 10
            .TextFrame2.TextRange.Font.Bold = msoTrue
            .Line.Visible = msoFalse
        End With

        ' H30 için konum al ve şekli ekle
        solKenar = ws.Range("H30").Left
        ustKenar = ws.Range("H30").Top
        Set sekil2 = ws.Shapes.AddShape(msoShapeRectangle, solKenar, ustKenar, genislik, yukseklik)
        With sekil2
            .TextFrame2.TextRange.Text = "Tabloya Dönüştür"
            .OnAction = "SeciliAlanıTabloyaDönüştür"
            .Fill.ForeColor.RGB = RGB(91, 155, 213)
            .TextFrame2.TextRange.Font.Size = 10
            .TextFrame2.TextRange.Font.Bold = msoTrue
            .Line.Visible = msoFalse
        End With

    Next ws

    MsgBox "Tüm sayfalara şekiller eklendi ve makro atandı.", vbInformation
 ThisWorkbook.Worksheets(1).Select
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst