Hücreleri formülleri ile kopyalama

[farisakboga]

Merhaba arkadaşlar.

Aşağıda paylaştığım dosyada öğrencilerim için oluşturduğum problemler var. Ben bu problemleri başka bir programda kullanmak üzere formülleri ile birlikte bir text dosyasına kopyalamak istiyorum. Mümkün mü acaba?

Kopyalamak istediğim alan Kalip sayfasındaki b2 ile n45 hücre aralığı. Texte yapıştırdığımızda sonucun aşağıdaki gibi görünmesini istiyorum.

Sınıfımızda 2'şerli oturulan =RASTGELEARADA(7;13) sıra, 3'erli oturulan =RASTGELEARADA(2;6) sıra vardır. Sınıfımızın mevcudu kaç kişidir?

Yardımlarınız için şimdiden teşekkürler.

 

[YUSUF44]

Makro kaydet yoluyla elde ettiğim aşağıdaki makro önce dosyaya yeni bir sayfa ekleyip Kalip sayfasıdnaki problemleri bu sayfaya aktarıyor. Sonra da bu sayfayı D'deki İndirilenler/Downloads klasörüne kaydediyor. Kaydetme klasörünü kendinize göre değiştirebilirsiniz:

Sub txtyap()
Set s1 = Sheets("Kalip")
son = s1.Cells(Rows.Count, "A").End(3).Row
Sheets.Add
For i = 2 To son
    sonsut = s1.Cells(i, Columns.Count).End(xlToLeft).Column
    yeni = ActiveSheet.Cells(Rows.Count, "A").End(3).Row + 1
    If ActiveSheet.[A1] = "" Then yeni = yeni - 1
    For j = 2 To sonsut
        If ActiveSheet.Cells(yeni, "A") = "" Then
            ActiveSheet.Cells(yeni, "A") = yeni & "- " & s1.Cells(i, j)
        Else
            ActiveSheet.Cells(yeni, "A") = ActiveSheet.Cells(yeni, "A") & " " & s1.Cells(i, j)
        End If
    Next
Next
Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="D:\Downloads\çarpma problemleri.txt", _
        FileFormat:=xlUnicodeText, CreateBackup:=False
Application.DisplayAlerts = True

End Sub

 

[farisakboga]

Makro kaydet yoluyla elde ettiğim aşağıdaki makro önce dosyaya yeni bir sayfa ekleyip Kalip sayfasıdnaki problemleri bu sayfaya aktarıyor. Sonra da bu sayfayı D'deki İndirilenler/Downloads klasörüne kaydediyor. Kaydetme klasörünü kendinize göre değiştirebilirsiniz:

Sub txtyap()
Set s1 = Sheets("Kalip")
son = s1.Cells(Rows.Count, "A").End(3).Row
Sheets.Add
For i = 2 To son
    sonsut = s1.Cells(i, Columns.Count).End(xlToLeft).Column
    yeni = ActiveSheet.Cells(Rows.Count, "A").End(3).Row + 1
    If ActiveSheet.[A1] = "" Then yeni = yeni - 1
    For j = 2 To sonsut
        If ActiveSheet.Cells(yeni, "A") = "" Then
            ActiveSheet.Cells(yeni, "A") = yeni & "- " & s1.Cells(i, j)
        Else
            ActiveSheet.Cells(yeni, "A") = ActiveSheet.Cells(yeni, "A") & " " & s1.Cells(i, j)
        End If
    Next
Next
Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:="D:\Downloads\çarpma problemleri.txt", _
        FileFormat:=xlUnicodeText, CreateBackup:=False
Application.DisplayAlerts = True

End Sub

Teşekkür ederim. Ancak formüller yok. Bana lazım olan formüller. Tek tek yapabilirim ama vakit alıyor. Formülleri de içerecek şekilde kodunuzu değiştirmek mümkün mü acaba?

 

[kulomer46]

Merhaba

Ekli dosyayı deneyiniz.

'Text Metni Kopyala' düğmesine tıklandığında ilgili veriler text olarak 'Text Metni Burada' Sayfasına aktarılmaktadır.
Ordan kopyalayıp text olarak istediğiniz yere yapıştırabilirsiniz.

Kolay Gelsin
Selamlar..

İlgili Kod

Sub Text_Olarak_kopyala()

Sheets("Text Metni Burada").Cells.ClearContents
For i = 2 To 45

    For j = 2 To 25  
        met = Cells(i, j).Formula
        metin = metin & "   " & Trim(met)
    Next
 
    metin = Replace(metin, "RANDBETWEEN", "RASTGELEARADA")
    metin = Replace(metin, "INDEX", "İNDİS")
 
    Sheets("Text Metni Burada").Cells(i, 2) = metin    
    metin = ""
 
Next

Sheets("Text Metni Burada").Select
Cells.RowHeight = 30
Cells(2, 1).Select

End Sub

 

[leguminosea]

Aşağıdaki linki inceleyin.

FORMÜLMETNİ işlevi - Microsoft Desteği

Sözdizimi: FORMÜLMETNİ(başvuru)

support.office.com

 

[farisakboga]

Merhaba

Ekli dosyayı deneyiniz.

'Text Metni Kopyala' düğmesine tıklandığında ilgili veriler text olarak 'Text Metni Burada' Sayfasına aktarılmaktadır.
Ordan kopyalayıp text olarak istediğiniz yere yapıştırabilirsiniz.

Kolay Gelsin
Selamlar..

İlgili Kod

Sub Text_Olarak_kopyala()

Sheets("Text Metni Burada").Cells.ClearContents
For i = 2 To 45

    For j = 2 To 25 
        met = Cells(i, j).Formula
        metin = metin & "   " & Trim(met)
    Next

    metin = Replace(metin, "RANDBETWEEN", "RASTGELEARADA")
    metin = Replace(metin, "INDEX", "İNDİS")

    Sheets("Text Metni Burada").Cells(i, 2) = metin   
    metin = ""

Next

Sheets("Text Metni Burada").Select
Cells.RowHeight = 30
Cells(2, 1).Select

End Sub

Çok teşekkür ederim.

 

[kulomer46]

Çok teşekkür ederim.

Selamlar...