Excel İçerik Kopyalama Makrosu

[number25]

Arkadaşlar merhaba Excelde bir tablom var şu şekilde;



Yukarıda ki tabloda "Yaka Kartı Bilgileri" altında ki bilgileri bir türlü aşağıda ki görüntüye çeviremedim. Ancak şöyle oluyor içeriği kopyalarsam eğer ayırıyor bilgileri ona okey ama veri çok fazla olduğunda bu kopyala yapıştıra giriyor. Makro olarak kopyala yapıştır yapıyorum ama hücreyi komple kopyalıyor makroda içeriği kopyalamayı bulamadım.

İşin özü sonunda yapmayı istediğim form çıktısı aşağıda ki gibidir var mı yardım edebilecek :/

 

[Necdet]

Merhaba,
örnek dosyanızı (bir kaç satırlık) paylaşım sitelerinden birine yüklerseniz, ve olması gerekeni de belirtirseniz yanıt almanız daha hızlı olacaktır.

Büyük Dosyalar Gönderme - Dosya Paylaşımı - TransferNow

Transfer başına 250 GB'a kadar büyük dosyaları göndermek ve paylaşmak için en kolay, en hızlı ve en güvenli ücretsiz dosya aktarım çözümü. Kayıt gerekmez.

www.transfernow.net

Dosya Upload - Dosya Yükle indir

Ücretsiz olarak dosya upload edebileceğiniz dosya yükleme sitesi. Hızlı dosya yükle ve paylaş.

www.dosyaupload.com

Send Large Files Free - Fast Secure File Transfer - Filemail

Send large files free via email and links. Paid accounts share files of any size. Fast secure online file transfer using our file sharing site & apps.

www.filemail.com

Dosya Yükle - Dosya Upload

Dosyalarınızı ücretsiz yükleyebilir ve paylaşabilirsiniz.

dosya.co

Dosya.tc - Ücretsiz, Hızlı ve Kolay Dosya Paylaşımı - Dosya Upload

Dosya.tc, dosya yükleme ve paylaşım platformudur. Her türlü veriyi (dosya, resim, müzik, video vb.) saklayabilir ve paylaşabilirsiniz. Tamamen ücretsiz, üyeliğe gerek yok. Hiçbir limit yok. Dosya Upload. Dosya Paylaş. Dosya Yükle

s6.dosya.tc

 

[number25]

Olmasını istediğim çıktı şu şekilde;

PATİKA YAKA KARTI teslim.xlsx - 13 KB


Altta ki ise düzenlenmemiş hali tek tek elle yukarıda ki gibi yapmak zaman alıyor. Teşekkür ederim.

katalog-başvuru-formu-tr-5-2024-05-07 (1).xlsx - 10 KB

 

[Necdet]

Merhaba,
Farklı çözümler üretilebilinir.
Aşağıdaki kodları deneyiniz.
Veriler Veri sayfasında, düzenlenmiş hali Liste sayfasında olmalı.
Bu iki sayfanın olması gerekir.

Sub Duzenle()

Dim arV As Variant
Dim arL As Variant
Dim ar1 As Variant
Dim ar2 As Variant
Dim shV As Worksheet
Dim shL As Worksheet

Dim i   As Long
Dim j   As Long
Dim k   As Integer

Set shV = Sheets("Veri")
Set shL = Sheets("Liste")

On Error Resume Next
Application.ScreenUpdating = False

shL.Cells.ClearContents
shL.Range("A1").Resize(1, 3) = Array("GALERİ ADI", "ADI SOYADI", "GÖREVİ")

arV = shV.Range("A1").CurrentRegion.Value
j = 2
For i = 2 To UBound(arV, 1)
    ar1 = Split(arV(i, 2), Chr(10))
    shL.Cells(j, "A") = arV(i, 1)
    For k = 1 To UBound(ar1)
        shL.Cells(j, "A") = BKH(CStr(arV(i, 1)))
        shL.Cells(j, "B") = BKH(CStr(Split(ar1(k), " | ")(0)))
        shL.Cells(j, "C") = BKH(CStr(Split(ar1(k), " | ")(1)))
        j = j + 1
    Next k
Next i

Application.ScreenUpdating = True

MsgBox "Listeleme Bitmiştir...."

End Sub

Function BKH(Sozcuk As String, Optional Tip As Integer = 2) As String

    'Tip    1. Küçük Harf
    '       2. Büyük Harf
    '       3. Yazım Düzeni
    
    If Tip = 1 Then
        BKH = Evaluate("=LOWER(" & """" & Sozcuk & """" & ")")
    ElseIf Tip = 2 Then
        BKH = Evaluate("=UPPER(" & """" & Sozcuk & """" & ")")
    Else
        BKH = Application.WorksheetFunction.Proper(Sozcuk)
    End If
    
End Function

 

[Korhan Ayhan]

Merhaba,

Örnek dosyanızı farklı bir platforma yükleyebilirmisiniz. Ben paylaştığınız linkten erişemedim.

 

[number25]

Merhaba,
Farklı çözümler üretilebilinir.
Aşağıdaki kodları deneyiniz.
Veriler Veri sayfasında, düzenlenmiş hali Liste sayfasında olmalı.
Bu iki sayfanın olması gerekir.

Sub Duzenle()

Dim arV As Variant
Dim arL As Variant
Dim ar1 As Variant
Dim ar2 As Variant
Dim shV As Worksheet
Dim shL As Worksheet

Dim i   As Long
Dim j   As Long
Dim k   As Integer

Set shV = Sheets("Veri")
Set shL = Sheets("Liste")

On Error Resume Next
Application.ScreenUpdating = False

shL.Cells.ClearContents
shL.Range("A1").Resize(1, 3) = Array("GALERİ ADI", "ADI SOYADI", "GÖREVİ")

arV = shV.Range("A1").CurrentRegion.Value
j = 2
For i = 2 To UBound(arV, 1)
    ar1 = Split(arV(i, 2), Chr(10))
    shL.Cells(j, "A") = arV(i, 1)
    For k = 1 To UBound(ar1)
        shL.Cells(j, "A") = arV(i, 1)
        shL.Cells(j, "B") = Split(ar1(k), " | ")(0)
        shL.Cells(j, "C") = Split(ar1(k), " | ")(1)
        j = j + 1
    Next k
Next i

Application.ScreenUpdating = True

MsgBox "Listeleme Bitmiştir...."

End Sub

Gerçekten çok teşekkür ederim, listeye gönderilen ad soyad olsun görevi olsun bunları otomatik harflerini de büyütebilir miyiz?

 

[number25]

Merhaba,

Örnek dosyanızı farklı bir platforma yükleyebilirmisiniz. Ben paylaştığınız linkten erişemedim.

Korhan bey çok teşekkür ederim ilginize, Necdet bey sağolsun hallettim.

 

[Korhan Ayhan]

Formülle çözüm üretebilmek adına farklı bir platformda paylaşabilirmisiniz.

 

[Necdet]

Gerçekten çok teşekkür ederim, listeye gönderilen ad soyad olsun görevi olsun bunları otomatik harflerini de büyütebilir miyiz?

Neden olmasın?

4 Nolu mesajı günledim, kodları oradan alınız.

 

[number25]

Neden olmasın?

4 Nolu mesajı günledim, kodları oradan alınız.

Teşekkür ederim hemen deneyeceğim.

Formülle çözüm üretebilmek adına farklı bir platformda paylaşabilirmisiniz.

https://s6.dosya.tc/server19/y46b1f/PATIKA_YAKA_KARTI_teslim.xlsx.html Bu olmasını istediğim şekil.

https://s6.dosya.tc/server19/y46b1f/katalog-basvuru-formu-tr-5-2024-05-07__1_.xlsx.html Buda düzeltilmemiş hali, ilginize hayran kaldım. Formlarda normalde3-5 güne gelir cevaplar veya hiç gelmez teşekkür ederim sizlere..

 

[number25]

Neden olmasın?

4 Nolu mesajı günledim, kodları oradan alınız.

O functionı tam olarak nereye koymam gerekiyor?

 

[Necdet]

Hepsi bir yerde olabilir.

 

[number25]

Denedim fakat olmadı

 

[Necdet]

DosyayI İndirmek İçin TIKLAYINIZ

 

[number25]

DosyayI İndirmek İçin TIKLAYINIZ

Çok çok teşekkür ederim Necdet bey