• DİKKAT

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

veri kopyalama-taşıma

M

metin_0606

Katılım
1 Ağustos 2019
Mesajlar
839
Excel Vers. ve Dili
Türkçe excel 2016
İngilizce excel 2016
Sayfa1 isimli çalışma sayfama makrolar sayesinde veri getirtiyorum. Getirttiğim verileri olduğu hali ile mevcut makro ile yaz isimli sayfama kopyalayıp oradan da masa üstündeki LİSTE isimli klasörüme taşıyorum. Taşıdığım sayfa, ismini Sayfa1 isimli sayfanın T8 hücresinden alıyor. Benim yapmak istediğim Sayfa1 ismli sayfaya getirttiğim verileri süzerek süzülmüş hali ile yaz isimli sayfaya oradan da LİSTE isimli klasöre T8 hücresinden ismini alarak taşımak istiyorum. Tabiki şuan ki yaptığım işi kısaltacak makro varsa oda olabilir yani doğrudan süzülmüş hali T8 hücresinden ismini alarak doğrudan masa üstündeki LİSTE isimli klasöre de kopyalayabiliriz. Yardımlarınız için şimdiden Teşekkürler Örneğin T8 hücresinde gruplar var. A grubunu süzdük diyelim. Bu hali ile T8 hücresinden ismini alarak LİSTE isimli klasöre kopyalamak istiyorum. Tabiki son dolu satırı alacak şekilde kopyalayacak.
 

Ekli dosyalar

Kullandığım makrolar
Sub sayfaya_gönder()
Application.ScreenUpdating = False
On Error Resume Next
Set s1 = ThisWorkbook.Worksheets("Sayfa1")
Set s2 = ThisWorkbook.Worksheets("yaz")
s2.Range("a1:ıv65536").ClearContents
s2.Range("a1:ıv65536").Borders.LineStyle = xlNone
s2.Range("a1:ıv65536").Interior.ColorIndex = xlNone

For k = 1 To s1.Cells(7, 256).End(xlToLeft).Column
s2.Cells(1, k) = s1.Cells(7, k)
s2.Cells(1, k).Borders.LineStyle = s1.Cells(7, k).Borders.LineStyle
s2.Cells(1, k).Interior.ColorIndex = s1.Cells(7, k).Interior.ColorIndex
Next k

For i = 8 To s1.Range("A65536").End(xlUp).Row
If s1.Cells(i, 1) <> "" Then
sonsatir = s2.Range("A65536").End(xlUp).Row + 1

For k = 1 To s1.Cells(7, 256).End(xlToLeft).Column
s2.Cells(sonsatir, k) = s1.Cells(i, k)
s2.Cells(sonsatir, k).Borders.LineStyle = s1.Cells(i, k).Borders.LineStyle
s2.Cells(sonsatir, k).Interior.ColorIndex = s1.Cells(i, k).Interior.ColorIndex

Next k
End If
Next i

Set WshShell = CreateObject("WScript.Shell")
strDesktop = WshShell.SpecialFolders("Desktop")
Cells(1, "u") = strDesktop & "\LİSTE\"
Application.ScreenUpdating = True
MsgBox "İşlem TAMAM.", vbInformation
End Sub

*************
Sub sayfayı_Farklı_Kaydet() '
Klasor = Worksheets("Sayfa1").Range("u1").Value 'yol
Dosya_Adi = Worksheets("Sayfa1").Range("t8").Value 'kayıt adı
Sayfa_Adı = "yaz" 'kaydedilecek sayfa
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
uzanti = Right(ThisWorkbook.Name, InStr(1, StrReverse(ThisWorkbook.Name), ".", vbTextCompare))
If uzanti = ".xlsx" Then
FileFormatNum = 51
ElseIf uzanti = ".xlsm" Then
FileFormatNum = 52
ElseIf uzanti = ".xls" Then
FileFormatNum = -4143
ElseIf uzanti = ".xlsb" Then
FileFormatNum = 50
End If
Sheets(Sayfa_Adı).Copy
ActiveWorkbook.SaveAs Klasor & Dosya_Adi & uzanti, FileFormat:=FileFormatNum
ActiveWorkbook.Close SaveChanges:=False
MsgBox Klasor & Dosya_Adi & uzanti & " Dosya kayıt edildi"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub
 
Önceki kodları dikkate almadan bu şekilde deneyiniz .

Kod: 
Sub Emr_Farkli_Kaydet()
    
    Dim Lst As Worksheet, Yaz As Worksheet
    Dim TempFilePath As String, TempFileName As String
  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Set Lst = Sheets("Sayfa1")
    Set Yaz = Sheets("yaz")
    
    If Application.WorksheetFunction.Subtotal(2, Lst.Range("A8:T" & Lst.Rows(Lst.Rows.Count).End(xlUp).Row)) = 0 Then
        MsgBox "Farkli kaydedilecek uygun liste mevcut degil"
        Exit Sub
    End If
    
    Yaz.Cells().ClearContents
    Yaz.Cells().Borders.LineStyle = xlNone
    Yaz.Cells().Interior.ColorIndex = xlNone
    
    Lst.Range("A7:T" & Lst.Cells(Lst.Rows.Count, "T").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=Yaz.Range("A1")
  
    Set WshShell = CreateObject("WScript.Shell")
    ThisWorkbook.Sheets("yaz").Copy
    
    TempFilePath = WshShell.SpecialFolders("Desktop") + "\LİSTE\"
    TempFileName = Yaz.Range("T2")
    
    ActiveWorkbook.SaveAs TempFilePath & TempFileName
    ActiveWorkbook.Close SaveChanges:=False
    
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Islem Tamam.", vbInformation
End Sub
 

Ekli dosyalar

Sayın
EmrExcel16 zihninize sağlık gayet güzel olmuş J sütununa makro ile fotograf getirtiyorum. Fotograflı hali ilede veriyi makronuzla aynı şekilde kopyalayıp LİSTE klasörüne atmamız mümkünmü acaba
 
metin_0606' Alıntı:
Sayın
EmrExcel16 zihninize sağlık gayet güzel olmuş J sütununa makro ile fotograf getirtiyorum. Fotograflı hali ilede veriyi makronuzla aynı şekilde kopyalayıp LİSTE klasörüne atmamız mümkünmü acaba
Genişletmek için tıkla ...

Bu yeni bir istek mi , yoksa dosyada gözden kaçırdığım bir yer mi var. Eğer yeni bir istekse örnek dosya ekleyerek sorunuzu destekleyin lütfen.
 
Normalde resimli olarakta kopyaliyor çalışmanız ancak hücre boyutlarından büyük geliyor
 
Deneyin..
Kod: 
Sub Emr_Farkli_Kaydet()
    
    Dim Lst As Worksheet, Yaz As Worksheet
    Dim TempFilePath As String, TempFileName As String
    Dim resimler As Excel.shape
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    On Error Resume Next
    Set Lst = Sheets("Sayfa1")
    Set Yaz = Sheets("yaz")
    
    If Application.WorksheetFunction.Subtotal(2, Lst.Range("A8:T" & Lst.Rows(Lst.Rows.Count).End(xlUp).Row)) = 0 Then
        MsgBox "Farkli kaydedilecek uygun liste mevcut degil"
        Exit Sub
    End If
    
    Yaz.Cells().ClearContents
    Yaz.Cells().Borders.LineStyle = xlNone
    Yaz.Cells().Interior.ColorIndex = xlNone
    
    For Each resimler In Yaz.Shapes
    
        Select Case resimler.Type
            Case msoPicture, msoMedia, msoShapeTypeMixed, msoOLEControlObject, msoAutoShape
                resimler.Delete
        End Select
    Next
    
    Lst.Range("A7:T" & Lst.Cells(Lst.Rows.Count, "T").End(xlUp).Row).SpecialCells(xlCellTypeVisible).Copy Destination:=Yaz.Range("A1")
    
    Yaz.Rows("2:" & Lst.Rows(Lst.Rows.Count).End(xlUp).Row).RowHeight = 81.6
  
    Set WshShell = CreateObject("WScript.Shell")
    ThisWorkbook.Sheets("yaz").Copy
    
    TempFilePath = WshShell.SpecialFolders("Desktop") + "\LİSTE\"
    TempFileName = Yaz.Range("T2")
    
    ActiveWorkbook.SaveAs TempFilePath & TempFileName
    ActiveWorkbook.Close SaveChanges:=False
    
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "Islem Tamam.", vbInformation
End Sub
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst