• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

  • Forum yazılımı güncelenmiştir.

    Beklenmedik durumlar görürseniz lütfen yönetime iletin.

Birleşik Sütunları Ayırma.

U

universitelio

Katılım
1 Ocak 2024
Mesajlar
67
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ı
 
Merhaba,
Neden excel değil de pdf dosyası eklediniz?
Çözümü excelde istediğinize göre, neden?
 
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.
 
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..
 
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.
 
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.
 
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
 
muratboz06' Alıntı:
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
Genişletmek için tıkla ...
Murat Bey tekrardan ihtiyaç oldu ve defalarca denememe rağmen maalesef yapamadım. Gerekirse ücreti mukabilinde desteğinize ihtiyacım var. Size nasıl ulaşabilirim acaba?
 
Olay excellik değil, pdf'i excel olarak kaydetmeniz için bir program lazım. Ben ABBY Fine Reader ile dönüştürdüm.
 

Ekli dosyalar

Ouzz_z' Alıntı:
Olay excellik değil, pdf'i excel olarak kaydetmeniz için bir program lazım. Ben ABBY Fine Reader ile dönüştürdüm.
Genişletmek için tıkla ...
Hocam altın üyeliğim yok da harici siteye yükleme şansınız var mıdır?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst