Soru sonucu not defterine alıp copyalayarak not defterini silmek.

bycakir · 8 Şubat 2019

merhabalar;

aşağıdaki dosyada macroyu çalıştırdığımda gerekli bilgileri not defterine atıyor ardından not defterini açıyor. bazı özellikleri genişletmek istiyorum. not defterini açsın içindeki tüm bilgiyi kopyalasın ve not defterini silsin. kopyayı ben istediğim yere yapıştırabileyim. amacım kodların açıkta kalmaması şimdiden teşekkürler.

Ömer BARAN · 9 Şubat 2019

Merhaba.
Yanlış anlamıyorsam (ilgili verileri aynı belge açıkken ve aynı belge içinde kullanacağınızı varsayıyorum),
bu işlem için NOT DEFTERİ kullanmadan da sonuç alınabilir.
Ayrıca basit KES-YAPIŞTIR işlemiyle veriler görünmeyen bir alana/gizli bir sayfaya alınarak da tutulabilir.

Yine de farkli bir seçenek vereyim.
Kopyalanacak veri miktarına göre işlemin performansını bilemiyorum doğrusu, deneyip görmek lazım.

Aşağıdaki kodları BOŞ BİR MODULE yapıştırın. ROTA sayfasına veya başka bir sayfaya iki adet düğme (aynı sayfada olması gerekmez) eklemiş olun,
-- birinci düğme ROTA sayfasında mevcut verileri hafızaya almak içindir (bu düğme ile HAFIZA isimli makroyu ilişkilendirin).
Veriler hafızaya alındıktan sonra sayfadan silinir ve istediğiniz zaman tekrar yapıştırıncaya kadar hafızada kalır.
-- ikinci düğme kopyalanan verilerin, istediğiniz bir sayfada, istediğiniz bir hücreye (ben activecell diye seçili hücre olarak yazdım) yapıştırılması için.
Bu düğmeyle de YAPISTIR isimli makroyu ilişkilendirin. Yapıştırılacak sayfa/adres belli ise Activecell yerine Sheets(....).[C10] gibi adres yazarsınız.

Veri bir kez yapıştırıldığında, hafızadan silinir.
(yeni verileri hafızaya alıncaya kadar, eski veriler hafızada kasın isterseniz, Erase a satırını silin.
Bu kararı veri yığınının büyüklüğü ve performans bakımından değerlendirmenizde yarar var)

CSS:

Public a(), b

Sub HAFIZA()
a = Sheets("ROTA").Range("A4:D" & Sheets("ROTA").Cells(Rows.Count, 1).End(3).Row).Value2
b = UBound(a)
Sheets("ROTA").Range("A4:D" & Sheets("ROTA").Cells(Rows.Count, 1).End(3).Row).ClearContents
End Sub

Sub YAPISTIR()
If b = Empty Then
    MsgBox "Hafızada tutulan veri YOK!.", vbCritical, "..:: Ömer BARAN ::.."
    Exit Sub
End If
ActiveCell.Resize(b, 4) = a
Erase a: b = Empty
End Sub

bycakir · 16 Şubat 2019

merhabalar Ömer bey

öncelikle desteğiniz için teşekkürler. hafızaya alınan veriyi farklı bir programa yapıştırıyorum. bu işlemi yapabilmem içinde not defterindeki düzende kopyalanması gerekiyor aksi durumda program kopyaya aldığım veriyi görmüyor. yani örneğin kopyaya alacağım veri aşağıdaki şekilde olmalı

Kod:

Sub Rota()
     Dim myFile As String, adoStream As Object, NoA As Long, i As Long, myData As String
    Const adSaveCreateOverWrite = 2
    
    myFile = ThisWorkbook.Path & Application.PathSeparator & "Deneme.txt"
    
    
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2
    adoStream.Open
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    
    adoStream.WriteText "!IFS.COPYOBJECT"
    adoStream.WriteText vbCrLf
    adoStream.WriteText "$LU=ProdStructure"
    adoStream.WriteText vbCrLf
    adoStream.WriteText "$VIEW=PROD_STRUCTURE"
    adoStream.WriteText vbCrLf
    
    For i = 4 To NoA
        myData = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
                 Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
                 adoStream.WriteText myData
        adoStream.WriteText vbCrLf
    Next
    
    adoStream.SaveToFile myFile, adSaveCreateOverWrite
    adoStream.Close

aslında burada kopyaya alma işlemini bu kodların altına ekleme şansımız varmı yani bu kodların hepsini çalıştırdığımda istediğim düzende kopyaya alınmış bir verim hazır olacak. ben diğer programa geçip sadece CTRL+V dediğimde istediğim düzende kopyalanmış olan veriler diğer programa yapışmış olacak bu arada gider. program excell değil.

Ömer BARAN · 19 Şubat 2019

Tekrar merhaba.
Verdiğiniz kodlar sanırım Sayın @Haluk Bey'e ait.
Kendisinin konuyu fark etmesini sağlarsanız, verdiği kod'da düzenleme/ekleme yapacaktır diye düşünüyorum.
adoStream olaylarıyla ilgili pek bilgim yok malesef.
.

bycakir · 20 Şubat 2019

teşekkürler @Ömer BARAN bey.

@Haluk Bey den müsait olduğunda hayırlı baberleri bekliyorum artık.

halit3 · 20 Şubat 2019

Referanslarda bu olmalı
microsoft forms 2.0 object library

Rich (BB code):

Sub Rota()

Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject

Dim myFile As String, adoStream As Object, NoA As Long, i As Long, myData As String
Const adSaveCreateOverWrite = 2

myFile = ThisWorkbook.Path & Application.PathSeparator & "Rota.txt"

Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2
adoStream.Open

NoA = Range("B" & Rows.Count).End(xlUp).Row

adoStream.WriteText "!IFS.COPYOBJECT"
adoStream.WriteText vbCrLf
adoStream.WriteText "$LU=ProdStructure"
adoStream.WriteText vbCrLf
adoStream.WriteText "$VIEW=PROD_STRUCTURE"
adoStream.WriteText vbCrLf

For i = 4 To NoA
myData = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
adoStream.WriteText myData

clipboard.SetText myData
clipboard.PutInClipboard

adoStream.WriteText vbCrLf
Next
adoStream.SaveToFile myFile, adSaveCreateOverWrite
adoStream.Close

Set adoStream = Nothing
MsgBox "Rota dosyasına aktarım yapılmıştır.", vbInformation, "..::Ömür ÇAKIR::.."
Shell "notepad.exe " & "rota\Rota.txt"
End Sub

Haluk · 20 Şubat 2019

Referans eklemeye ve/veya API kullanmaya gerek kalmadan söz konusu Text dosyasını oluşturup, içini kopyalayarak hafızaya aldıktan sonra Text dosyasını silmek için, aşağıdaki kodları kullanabilirsiniz...

Kod:

Sub Test()
    'Haluk 20/02/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim myFile As String, adoStream As Object, NoA As Long, i As Long, myData As String
    Dim dataObject As Object
    
    Const adSaveCreateOverWrite = 2
    
    myFile = ThisWorkbook.Path & Application.PathSeparator & "Deneme.txt"
   
    Set adoStream = CreateObject("ADODB.Stream")
    adoStream.Charset = "utf-8"
    adoStream.Type = 2
    adoStream.Open
    
    NoA = Range("A" & Rows.Count).End(xlUp).Row
    
    adoStream.WriteText "!IFS.COPYOBJECT"
    adoStream.WriteText vbCrLf
    adoStream.WriteText "$LU=ProdStructure"
    adoStream.WriteText vbCrLf
    adoStream.WriteText "$VIEW=PROD_STRUCTURE"
    adoStream.WriteText vbCrLf
    
    For i = 4 To NoA
        myData = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
                 Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
                 adoStream.WriteText myData
        adoStream.WriteText vbCrLf
    Next
    
    adoStream.SaveToFile myFile, adSaveCreateOverWrite
    
    adoStream.LoadFromFile myFile
    
    myData = adoStream.ReadText
    
    adoStream.Close
     
    Set dataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    dataObject.SetText myData
    dataObject.PutInClipboard
    
    Kill myFile
    
    Set dataObject = Nothing
    Set adoStream = Nothing
End Sub

.

halit3 · 20 Şubat 2019

Ben apiler lazım olur diye eklemiştim 6 nolu mesajdaki apileri kaldırdım.

veyselemre · 20 Şubat 2019

Bir de bunu deneyin;

Kod:

Sub Test2()
    With CreateObject("Scripting.Dictionary")
        ver = "!IFS.COPYOBJECT": GoSub ekle
        ver = vbCrLf: GoSub ekle
        ver = "$LU=ProdStructure": GoSub ekle
        ver = vbCrLf: GoSub ekle
        ver = "$VIEW=PROD_STRUCTURE": GoSub ekle
        ver = vbCrLf: GoSub ekle

        For i = 4 To Range("A" & Rows.Count).End(xlUp).Row
            ver = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
                  Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
            GoSub ekle
            ver = vbCrLf: GoSub ekle
        Next

        Set dataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        dataObject.SetText Join(.items, "")
        dataObject.PutInClipboard

        Set dataObject = Nothing
        Exit Sub
ekle:
        .Item(.Count + 1) = ver
        Return
    End With
End Sub

Kod:

Sub Test3()
    With CreateObject("Scripting.Dictionary")
        ver = "!IFS.COPYOBJECT": GoSub ekle
        ver = "$LU=ProdStructure": GoSub ekle
        ver = "$VIEW=PROD_STRUCTURE": GoSub ekle

        For i = 4 To Range("A" & Rows.Count).End(xlUp).Row
            ver = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
                  Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
            GoSub ekle
        Next

        Set dataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        dataObject.SetText Join(.items, "")
        dataObject.PutInClipboard
        Set dataObject = Nothing
        Exit Sub
ekle:
        .Item(.Count + 1) = ver & vbCrLf
        Return
    End With
End Sub

halit3 · 20 Şubat 2019

Bende eklediğim kodları değiştirdim.

Rich (BB code):

Sub Rota()

Dim myFile As String, adoStream As Object, NoA As Long, i As Long, myData As String
Const adSaveCreateOverWrite = 2

myFile = ThisWorkbook.Path & Application.PathSeparator & "Rota.txt"

Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2
adoStream.Open

NoA = Range("B" & Rows.Count).End(xlUp).Row

ReDim veri(NoA)

adoStream.WriteText "!IFS.COPYOBJECT"
adoStream.WriteText vbCrLf
adoStream.WriteText "$LU=ProdStructure"
adoStream.WriteText vbCrLf
adoStream.WriteText "$VIEW=PROD_STRUCTURE"
adoStream.WriteText vbCrLf

For i = 4 To NoA
myData = "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
adoStream.WriteText myData
veri(i) = myData
adoStream.WriteText vbCrLf
Next



Dim clipboard As MSForms.DataObject
Set clipboard = New MSForms.DataObject
clipboard.SetText Join(veri)
clipboard.PutInClipboard

adoStream.SaveToFile myFile, adSaveCreateOverWrite
adoStream.Close

Set adoStream = Nothing
MsgBox "Rota dosyasına aktarım yapılmıştır.", vbInformation, "..::Ömür ÇAKIR::.."
Shell "notepad.exe " & "rota\Rota.txt"
End Sub

Haluk · 20 Şubat 2019

Veysel beyin belirttiği gibi, Text dosyasını sonradan sildiğimize göre; oluşturmaya da gerek yok tabii... Soruda istendiği için öyle yapmıştık ama gereksiz bir şey aslında.

O zaman, benim 7 No'lu mesajdaki kod, şu şekilde olur...

Not: Birbirine eklenecek veriler çok fazla değilse, o zaman "&" ile eklemekte sakınca yok. Eğer çok fazla veri varsa o zaman aşağıdaki linkte Zeki Beyin belirttiği yöntemi kullanmak gerekir.

https://www.excel.web.tr/threads/stringbuilder-oernegi.173050/

Aşağıdaki "&" ile birleştirilerek hazırlanan kodun performansı, Veysel Beyin Scripting.Dictionary metoduna göre muhtemelen daha yavaştır.

Kod:

Sub Test2()
    'Haluk 20/02/2019
    'E-Posta: sa4truss@gmail.com
    '
    Dim myFile As String, adoStream As Object, NoA As Long, i As Long, myData As String
    Dim dataObject As Object
  
    NoA = Range("A" & Rows.Count).End(xlUp).Row
  
    myData = "!IFS.COPYOBJECT"
    myData = myData & vbCrLf
    myData = myData & "$LU=ProdStructure"
    myData = myData & vbCrLf
    myData = myData & "$VIEW=PROD_STRUCTURE"
    myData = myData & vbCrLf
  
    For i = 4 To NoA
        myData = myData & "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
                 Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"

        myData = myData & vbCrLf
    Next
  
    Set dataObject = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    dataObject.SetText myData
    dataObject.PutInClipboard
  
    Set dataObject = Nothing
    Set adoStream = Nothing
End Sub

bycakir · 21 Şubat 2019

hepinize teşekkürler.

@veyselemre beyin verdiği kodlar dediğiniz gibi tex gerektirmeden çalışıyor bu benim için daha iyi oldu fakat bir detay var çözemedim Veysel bey.
aşağıda 2 kodunuzunda yapıştırma şekli görünmekte 1 satır sorunsuz ama diğer satırların başında 1 boşluk var bunları kaldırmam gerek yardımcı olurmusunuz?

bycakir · 21 Şubat 2019

@halit3 bey sizin son eklediğiniz kodda da "clipboard As MSForms.DataObject" hatası verdi

bycakir · 21 Şubat 2019

@Haluk bey sizin kodunuz sorunsuz çalıştı

hepinizin ellerine sağlık çok teşekkür ediyorum

veyselemre · 21 Şubat 2019

dataObject.SetText Join(.items, "")

halit3 · 21 Şubat 2019

Bir de bu kodu deneyiniz.

Kod:

Sub Rota()

son = Range("B" & Rows.Count).End(xlUp).Row

ReDim veri(son)
veri(0) = "!IFS.COPYOBJECT"
veri(1) = vbCrLf & "$LU=ProdStructure"
veri(2) = vbCrLf & "$VIEW=PROD_STRUCTURE"
For i = 4 To son
myData = vbCrLf & "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
veri(i - 1) = myData
Next

Set clipboard = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText Trim(Join(veri))
clipboard.PutInClipboard

End Sub

bycakir · 21 Şubat 2019

@veyselemre bey çok teşekkürler sorun düzeldi
@halit3 bey farkli bir mod çıkıyor bu verdiğiniz kodda

hepinize sonsuz teşekkürler..

halit3 · 21 Şubat 2019

16 nolu kodu güncelledim.

bycakir · 22 Şubat 2019

@halit3 bey out of range hatası veriyor veri(2) = vbCrLf & "$VIEW=tekno_sarf_kontrol" bu satırda

halit3 · 22 Şubat 2019

bycakir' Alıntı:
@halit3 bey out of range hatası veriyor veri(2) = vbCrLf & "$VIEW=tekno_sarf_kontrol" bu satırda

1 nolu mesajdaki dosyada bu kod çalışıyor.

Kod:

Sub Rota()

son = Range("B" & Rows.Count).End(xlUp).Row

ReDim veri(son)
veri(0) = "!IFS.COPYOBJECT"
veri(1) = vbCrLf & "$LU=ProdStructure"
veri(2) = vbCrLf & "$VIEW=PROD_STRUCTURE"
For i = 4 To son
myData = vbCrLf & "$RECORD=!" & vbLf & "-$5:=" & Range("A" & i) & vbLf & "-$6:=" & _
Range("B" & i) & vbLf & "-$12:=" & Range("C" & i) & vbLf & "-$26:=" & Range("D" & i) & vbLf & "-"
veri(i - 1) = myData
Next

Set clipboard = CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
clipboard.SetText Trim(Join(veri))
clipboard.PutInClipboard

End Sub

Soru sonucu not defterine alıp copyalayarak not defterini silmek.

bycakir

Ekli dosyalar

Ömer BARAN

Uzman

bycakir

Ömer BARAN

Uzman

bycakir

halit3

Uzman

Ekli dosyalar

Haluk

𐱅𐰇𐰼𐰚

halit3

Uzman

veyselemre

Özel Üye

halit3

Uzman

Haluk

𐱅𐰇𐰼𐰚

bycakir

bycakir

bycakir

veyselemre

Özel Üye

halit3

Uzman

bycakir

halit3

Uzman

bycakir

halit3

Uzman