• DİKKAT

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

Makro ile Özel Yapıştır

S

schlecht

Katılım
13 Kasım 2009
Mesajlar
337
Excel Vers. ve Dili
Ofis 2016 TR 64 Bit
merhaba,

dosya_adi = Yol & "\" & k_dosya_adi & ".xlsx"
Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)
Set S1 = K2.Worksheets("Sheet1")
Son = S1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count
'MsgBox (Son)

S1.Range(k_range & Son).Copy K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic)
K2.Close False

kapalı iki dosya arası veri kopyalamak için kullandığım kod bu şekilde, bu koda özel yapıştır kodunu nasıl ekleyebilirim ?

kopyalanan veriyi değer olarak yapıştırmak istiyorum.

Bir de sola hizalanabilir mi böyle bit şey mümkün mü?

Teşekkürler..
 
Aşağıdaki şekilde deneyiniz.

Kod: 
dosya_adi = Yol & "\" & k_dosya_adi & ".xlsx"
Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)
Set S1 = K2.Worksheets("Sheet1")
Son = S1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count
'MsgBox (Son)

S1.Range(k_range & Son).Copy Destination:=K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic)[B][COLOR=Red].PasteSpecial Paste:=xlPasteValues[/COLOR][/B]
K2.Close False
 
Son düzenleme:
Bende test edemedim.
Bir de bu şekilde deneyin. Kod güncellendi.

​
 
Malesef yine hata verdi. Tamamını paylaşmsam daha yararlı olacak gibi. "PasteSpecial Paste:" ile çözemedim bir türlü sorunu.. İlginize teşekkür ederim...

Sub Kopyala()
'
' Kopyala Makro
'
' Klavye Kısayolu: Ctrl+x

Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set Excel_Uygulama = CreateObject("Excel.Application")
Excel_Uygulama.Visible = False

' 1 ------------------------------------------------
MsgBox ("Kaynak dosyaların olduğu klasörü seçin")

kaynak_path = GetFolder("C:\")

'Yol = ActiveWorkbook.Path
Yol = kaynak_path

' 2 -------------------------------------------------
MsgBox ("Çalışma kağıdını seçin")

calisma_kagidi = GetFile("C:\")

Set K1 = Excel_Uygulama.Workbooks.Open(calisma_kagidi)

For Each c In ActiveSheet.Range("A3:a34").Cells

If c.Value = "Evet" Then
For Each cc In ActiveSheet.Range("A" & c.Row & ":j" & c.Row).Cells
If cc.Column = 3 Then
kontrol_noktasi_kodu = cc.Value
ElseIf cc.Column = 4 Then
c_baslangic = cc.Value
ElseIf cc.Column = 8 Then
k_dosya_adi = cc.Value
ElseIf cc.Column = 9 Then
k_range_start = cc.Value
ElseIf cc.Column = 10 Then
k_range_end = cc.Value
End If

Next cc

k_range = k_range_start & ":" & k_range_end

dosya_adi = Yol & "\" & k_dosya_adi & ".xlsx"
Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)
Set S1 = K2.Worksheets("Sheet1")
Son = S1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count
'MsgBox (Son)


S1.Range(k_range & Son).Copy K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic)
K2.Close False


End If
Next c

K1.Save
K1.Close True

Set S1 = Nothing
Set K1 = Nothing
Set K2 = Nothing
Set Excel_Uygulama = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
'
End Sub
 
Yardımcı olabilicek olan var mı ? Çıkamadım işin içinden
 
Kopyalama işlemini yapan satırı aşağıdaki gibi değiştirip deneyiniz.

Kod: 
S1.Range(k_range & Son).Copy
K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic).PasteSpecial Paste:=xlPasteValues
Selection.HorizontalAlignment = xlLeft
 
İlginize teşekkür ederim.

Selection.HorizontalAlignment = xlLeft

burda hata aldım.
 
merhaba, günlerdir uğraşıyorum fakat bir çözüm bulamadım.

k_range = k_range_start & ":" & k_range_end

dosya_adi = Yol & "\" & k_dosya_adi & ".xlsx"
Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)
Set S1 = K2.Worksheets("Sheet1")
Son = S1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count
'MsgBox (Son)


S1.Range(k_range & Son).Copy K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic).Select
Selection.PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

K2.Close False

Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)

burada hata alıyorum.
 
Son düzenleme:
Kopyalama sorununu çözdüm fakat bu seferde "excel pano üstündeki bilgi miktarı çok büyük" hatası
verdi. Çok araştırdım

Application.DisplayAlerts = False
Application.DisplayAlerts = True

ile sorunun çözülebileceğini yazanlar çok ama bu kodları nereye yazmalıyım.
Yardımlarınızı rica ediyorum.

İyi günler.
 
Hata nerede oluşuyorsa ondan önce False olanı, sonra da true olanı kullanmalısınız.
 
Aslında hata değilde uyarı sanırım. Evet ya da Hayır diyince kopyalama işlemini yapıyor fakat Evet ya da Hayır a 25 kere basmam gerekiyor.
Bu uyarının çıkmaması mümkün mü?
 

Ekli dosyalar

  • 1.PNG
    1.PNG
    9.5 KB · Görüntüleme: 4
Kodlarınızı bilmeden cevap vermek zor. Kopyalama işleminden önce False satırını ekleyin, tüm işlemlerden sonra da True satırını ekleyip deneyin.
 
Function GetFolder(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function

Function GetFile(strPath As String) As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFilePicker)
fldr.Filters.Clear
fldr.Filters.Add "Excel files", "*.xlsx"
With fldr
.Title = "Select a File"
.AllowMultiSelect = False
.InitialFileName = strPath
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFile = sItem
Set fldr = Nothing
End Function



Sub Kopyala()
'
' Kopyala Makro
'



Dim K1 As Object, K2 As Object, S1 As Worksheet, Son As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set Excel_Uygulama = CreateObject("Excel.Application")
Excel_Uygulama.Visible = False
Application.DisplayAlerts = False

' 1 ------------------------------------------------
MsgBox ("Kaynak dosyaların olduğu klasörü seçin")

kaynak_path = GetFolder("C:\")

'Yol = ActiveWorkbook.Path
Yol = kaynak_path

' 2 -------------------------------------------------
MsgBox ("Bireysel Krediler Çalışma kağıdını seçin")

calisma_kagidi = GetFile("C:\")

Set K1 = Excel_Uygulama.Workbooks.Open(calisma_kagidi)

For Each c In ActiveSheet.Range("A3:A150").Cells

If c.Value = "Evet" Then
For Each cc In ActiveSheet.Range("A" & c.Row & ":j" & c.Row).Cells
If cc.Column = 3 Then
kontrol_noktasi_kodu = cc.Value
ElseIf cc.Column = 4 Then
c_baslangic = cc.Value
ElseIf cc.Column = 8 Then
k_dosya_adi = cc.Value
ElseIf cc.Column = 9 Then
k_range_start = cc.Value
ElseIf cc.Column = 10 Then
k_range_end = cc.Value
End If

Next cc


k_range = k_range_start & ":" & k_range_end

dosya_adi = Yol & "\" & k_dosya_adi & ".xlsx"
Set K2 = Excel_Uygulama.Workbooks.Open(dosya_adi)
Set S1 = K2.Worksheets("Sheet1")
Son = S1.Range("C:C").Cells.SpecialCells(xlCellTypeConstants).Count
'MsgBox (Son)


S1.Range(k_range & Son).Copy

K1.Sheets(kontrol_noktasi_kodu).Range(c_baslangic).PasteSpecial Paste:=xlPasteAllExceptBorders, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False






K2.Close False


End If
Next c

K1.Save
K1.Close True

Set S1 = Nothing
Set K1 = Nothing
Set K2 = Nothing
Set Excel_Uygulama = Nothing

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

MsgBox "İşleminiz tamamlanmıştır.", vbInformation
'
End Sub

Kodlar bu şekilde dediğinizi yaptım ama malesef olmadı..
 
Fikrim yok maalesef.

Yalnız kodda false satırı var ama true satırı yok. Aklınızda bulunsun false yaptığınız bir ayarı daha sonra true olarak düzeltmezseniz sürekli false olarak kalır, yani çalışmaz. Örneğin bu kodda pasiflediğiniz uyarılar nedeniyle artık hiç uyarı almazsınız.
 
İlgilendiğiniz için teşekkürler. Bir çözüm bulursam paylaşırım. İyi geceler.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst