Merhabalar.
"Klasör ve dosya oluşturma seçenekleri"
http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html
Aşağıdaki kod değerli üstad Sayın Halit Hocamızın üstteki başlıkta işlediği envai çeşit kodlardan birtanesi.
Kendisine bir kez daha teşekkür ediyorum.
Kodun mantığı seçilen bir dosyanın sayfalarının tamamını yada sadece seçili olanları başka bir dosyaya kopyalamak.
Ben kodu denemek istediğimde bu satırda hata aldım.
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
Saygıdeğer Hocam;
Ben bu kodu şayet mümkünse şu şekilde kullanmak istiyorum.
** Kodun şu halinde olduğu gibi açılır pencere gelecek.
** Ben bir dosya seçeceğim ve bu dosyanın içindeki tüm sayfalar klick yapmak için pencerede gözükecek.
(Yada aktarılacak sayfaları manuelde yazabilirim sorun olmaz)
** Klick yaptığım/belirlediğim sayfalar daha sonraki seçtiğim dosyaya aktarılacak.
** İşlem bittiğinde aktarılan sayfalar kaynak dosyadan silinsinmi/silinmesinmi diye soracak (Bu soruyu en baştada sorabilir)
İnşallah meramımı anlatabilmişimdir.
Tekrar teşekkür ediyor saygılar sunuyorum.
"Klasör ve dosya oluşturma seçenekleri"
http://www.excel.web.tr/f133/klasor-ve-dosya-olu-turma-secenekleri-t68040.html
Aşağıdaki kod değerli üstad Sayın Halit Hocamızın üstteki başlıkta işlediği envai çeşit kodlardan birtanesi.
Kendisine bir kez daha teşekkür ediyorum.
Kodun mantığı seçilen bir dosyanın sayfalarının tamamını yada sadece seçili olanları başka bir dosyaya kopyalamak.
Ben kodu denemek istediğimde bu satırda hata aldım.
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
Saygıdeğer Hocam;
Ben bu kodu şayet mümkünse şu şekilde kullanmak istiyorum.
** Kodun şu halinde olduğu gibi açılır pencere gelecek.
** Ben bir dosya seçeceğim ve bu dosyanın içindeki tüm sayfalar klick yapmak için pencerede gözükecek.
(Yada aktarılacak sayfaları manuelde yazabilirim sorun olmaz)
** Klick yaptığım/belirlediğim sayfalar daha sonraki seçtiğim dosyaya aktarılacak.
** İşlem bittiğinde aktarılan sayfalar kaynak dosyadan silinsinmi/silinmesinmi diye soracak (Bu soruyu en baştada sorabilir)
İnşallah meramımı anlatabilmişimdir.
Tekrar teşekkür ediyor saygılar sunuyorum.
Kod:
Private Sub CheckBox1_Click()
Dim i As Integer
For i = 1 To ListBox1.ListCount
ListBox1.Selected(i - 1) = CheckBox1.Value
Next
End Sub
Private Sub CommandButton2_Click()
Dim myArray() As Variant
Dim i As Integer
Dim yer
son = 0
If Label2 = "" Then
MsgBox "kopyası alınacak dosyayı seçmediniz.?", vbInformation, "DİKKAT"
Exit Sub
Else
End If
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
son = 1
End If
Next
If son = 0 Then
MsgBox "Sayfa seçimi yapmadınız"
Exit Sub
End If
b = MsgBox("Sayfadaki makrolar silinsinmi.?", vbYesNo + vbInformation, " uyarı")
c = MsgBox("Formüller silinsinmi.?", vbYesNo + vbInformation, " uyarı")
dosya_adı = ActiveWorkbook.Name
Sayfa_Adı = ActiveSheet.Name
Dim wb As Workbook
On Error Resume Next
Set wb = Workbooks.Open(Label2)
veri_dosya_adı = ActiveWorkbook.Name
'Windows(dosya_adı).Activate
n = 0
For i = 1 To ListBox1.ListCount
If ListBox1.Selected(i - 1) = True Then
ReDim Preserve myArray(n)
myArray(n) = i
n = n + 1
End If
Next
Sheets(myArray).Select
Sheets(myArray).Copy Before:=Workbooks(dosya_adı).Sheets(1)
Windows(dosya_adı).Activate
'ThisWorkbook.Worksheets(sat).Select
If b = vbYes Then
For k = 1 To n 'ActiveWorkbook.Sheets.Count
Application.EnableEvents = False
With ActiveWorkbook.VBProject.VBComponents(Worksheets(k).CodeName).CodeModule
.DeleteLines 1, .CountOfLines
End With
Sheets(Sheets(k).Name).Select
Sheets(Sheets(k).Name).DrawingObjects.Delete
Next k
End If
If c = vbYes Then
For k = 1 To n 'ActiveWorkbook.Sheets.Count
If WorksheetFunction.CountA(Sheets(Sheets(k).Name).Cells) > 0 Then
sat = Sheets(Sheets(k).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = Sheets(Sheets(k).Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
Dim X As Range
For Each X In Sheets(Sheets(k).Name).Range(Sheets(Sheets(k).Name).Cells(1, 1), Sheets(Sheets(k).Name).Cells(sat, sut))
If X.Value <> "" Then
X.Value = X.Value
End If
Next X
End If
Next k
End If
Windows(veri_dosya_adı).Activate
ActiveWindow.Close
Windows(dosya_adı).Activate
Sheets(Sayfa_Adı).Select
Label2 = ""
ActiveWindow.WindowState = xlMaximized
MsgBox "işlemi tamanlandı"
End Sub
Private Sub CommandButton1_Click()
ListBox1.Clear
sat1 = 0
Dosya_Yolu = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*") ', Title:="Choose Files", MultiSelect:=True)
'Dosya_Yolu = Application.GetOpenFilename(fileFilter:="Excel Dosyaları (*.xls;*.xlsx;*.xlsm;*.xlsb),*.xls;*.xlsx;*.xlsm;*.xlsb")
'Dosya_Yolu = Application.GetOpenFilename("All Files (*.*),*.*.")
If Dosya_Yolu = False Then
MsgBox "Dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
Label2 = Dosya_Yolu
Dim Katalog As Object, Data As Object, Tablo As Object
Dim son1
Set Data = CreateObject("ADODB.Connection")
Set Katalog = CreateObject("ADOX.Catalog")
Data.Open "Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};Dbq=" & Dosya_Yolu & ";"
Katalog.ActiveConnection = Data
For Each Tablo In Katalog.Tables
'MsgBox Tablo.Name
If InStr(1, Tablo.Type, "TABLE") > 0 Then
If Right(Tablo.Name, 19) <> "kaynağından_sorgula" Then
If Right(Tablo.Name, 14) <> "Yazdırma_Alanı" Then
son1 = Replace(Tablo.Name, "'", "")
If Right(son1, 1) <> "_" Then
If Right(son1, 1) = "$" Then
ListBox1.AddItem
ListBox1.List(sat1, 0) = Left$(son1, Len(son1) - 1)
sat1 = sat1 + 1
End If
End If
End If
End If
End If
Next
Set Data = Nothing
Set Katalog = Nothing
End Sub
Private Sub UserForm_Initialize()
ListBox1.ListStyle = 1
ListBox1.MultiSelect = 1
End Sub
