Makro ile dosya kopyalama

[fyucel]

Arkadaşlar bir klasörde kayıtlı herhangi bir dosyayı
başka bir klasöre makro ile kopyalamak istiyorum.
Klasörler önceden oluşturulmuş sadece dosya ismi belirtip
kopyalama yapıcaz.
....
Ayrıca, makro içinde "Pİ()" , "3.14" sayısını kullanamıyorum
bu konularda yardımcı olursanız memnun olurum.

 

[halit3]

dosya kopyalama için kod

Sub Makro5()
a = Application.FindFile
'a = Application.GetOpenFilename("All Files (*.*),*.*.")
If a = False Then
MsgBox "Veri alınacak dosyayı seçmediniz.", vbInformation, "DİKKAT"
Exit Sub
Else
End If
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim Baslik As String
Baslik = "Dosyanın Kayıt yapılacağı Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path
If Len(kaynak) = 3 Then
kaynak = Mid(kaynak, 1, 2)
Else
kaynak = kaynak
End If
If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
yeni = Mid(Dir(a), 1, Len(Dir(a)) - 4)
deger = InputBox("Dosya isimini değiştirebilirsiniz.", "UYARI!", yeni)
DosyaSistemi.CopyFile Dir(a), kaynak & "\" & deger & Right(Dir(a), 4)
Else
Atla:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[fyucel]

değerli halit kardeşim ilgi ve alakanız için teşekkür ederim, göndermiş olduğunuz makro, dosyayı açtıktan sonra kopyalıyor, ilk etapta sadece *.xls dosyalarını görüyor ve dosyaları tek, tek açarak kopyalıyor,
benim isteğim,
Gösterdiğim klasör içindeki bütün dosyların, göstereceğim diğer klasöre bir çırpıda kopyalanması, ilginize tekrar teşekkür edrim.

 

[cansuyerlikaya]

arkadaşlar yeni üye oldum
bi konuda soru soracağım ama
konu bulamıyorum konu nerden başlatılıyor bilen varsa yardım etsin lütfen

 

[halit3]

değerli halit kardeşim ilgi ve alakanız için teşekkür ederim, göndermiş olduğunuz makro, dosyayı açtıktan sonra kopyalıyor, ilk etapta sadece *.xls dosyalarını görüyor ve dosyaları tek, tek açarak kopyalıyor,
benim isteğim,
Gösterdiğim klasör içindeki bütün dosyların, göstereceğim diğer klasöre bir çırpıda kopyalanması, ilginize tekrar teşekkür edrim.

o zaman klasörün tamamını kapyalamak istediğiniz anlaşılıyor

işte kod

Sub klasörüyedekle()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Dim Baslik As String
Baslik = "Kaynak Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor = Obj.BrowseForFolder(0, Baslik, 50, &H0)
kaynak = Klasor.items.Item.Path

If Not Klasor Is Nothing Then
If InStr(1, kaynak, "{") > 0 Then GoTo Atla
On Error Resume Next
On Error Resume Next
Dim ekBaslik As String
ekBaslik = "Hedef Dosyaları İçeren Klasörü Seçin"
Set Obj = CreateObject("shell.application")
Set Klasor1 = Obj.BrowseForFolder(0, ekBaslik, 50, &H0)
Kaynak1 = Klasor1.items.Item.Path
If Len(Kaynak1) = 3 Then
Kaynak1 = Mid(Kaynak1, 1, 2)
Else
Kaynak1 = Kaynak1
End If
If Not Klasor1 Is Nothing Then
If InStr(1, Kaynak1, "{") > 0 Then GoTo Atla1
On Error Resume Next
deger = InputBox("UYARI!" & Chr(10) & _
Chr(10) & " Yeni yedek Klasörün adını yazınız " & Chr(10) & Chr(10) & _
"", _
"DİKKAT !", "", , , "DEMO.HLP", 10)
On Error Resume Next
DosyaSistemi.CopyFolder kaynak, Kaynak1 & "\" & deger
Else
Atla:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Else
Atla1:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

End Sub

 

[halit3]

arkadaşlar yeni üye oldum
bi konuda soru soracağım ama
konu bulamıyorum konu nerden başlatılıyor bilen varsa yardım etsin lütfen

excell sorularu başlığı altında excelle yeni başlayanlar başlığını tıkla acılan pencerede yeni konu başlığını göreceksin o yazının üstünü tıkla gerisi size kalmış kolay gelsin

 

[mustilem23]

Halit hocam konuyu araştırır iken rast geldim bu konuya benimde aynı şekilde bir kod ihtiyacım var yardımcı olabilir iseniz çok sevinirim iyi günler.

öyle bir şey yapmak istiyorum ki tedarikçilere teknik resim gönderme şeklini otomatiğe bağlamaya çalışacağım.

bizim her teknik resmimizin bir kodu var bunların hepsi bir klasör de ben excele kodları bir stüna yapıştırdığım da yaklaşık (100 civarı) bu kodları belirttiğim klasör den alıp emaile yada ayrı bir klasöre kopyalamak istiyorum .
Not:kopyalanacak dosyalar .pdf formatın da dır.

 

[halit3]

Halit hocam konuyu araştırır iken rast geldim bu konuya benimde aynı şekilde bir kod ihtiyacım var yardımcı olabilir iseniz çok sevinirim iyi günler.

öyle bir şey yapmak istiyorum ki tedarikçilere teknik resim gönderme şeklini otomatiğe bağlamaya çalışacağım.

bizim her teknik resmimizin bir kodu var bunların hepsi bir klasör de ben excele kodları bir stüna yapıştırdığım da yaklaşık (100 civarı) bu kodları belirttiğim klasör den alıp emaile yada ayrı bir klasöre kopyalamak istiyorum .
Not:kopyalanacak dosyalar .pdf formatın da dır.

Tam olarak ne demek istediğinizi anlıyamadım.

Konu bütünlüğü bozulmaması için sorunuzu farklı bir konu başlığı altında yeni bir konu açarak sorun.

kod:

Sub dasyakopyala()
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
veriKlasor = "C:\Documents and Settings\admin\Desktop\Yeni Klasör\"
hedefKlasor = "C:\Documents and Settings\admin\Desktop\DENEME\"
On Error Resume Next
For i = 1 To [a65536].End(3).Row
Dosya = veriKlasor & Cells(i, 1).Value
If CreateObject("Scripting.FileSystemObject").FileExists(Dosya) = True Then
DosyaSistemi.CopyFile Dosya, hedefKlasor & Cells(i, 1).Value
End If
Next i
End Sub

Not: Bu kod A sutundaki dosya isimlerini farklı klasöre kayıt yapıyor

 

[mustilem23]

halit bey yeni konu olarak ekledim yardımcı olabilir misiniz daha detaylı anlatmaya çalıştım.

http://www.excel.web.tr/f48/makro-ile-klasorden-klasore-yada-emaili-dosya-kopyalama-t116771.html#post637272

 

[halit3]

yanlış oldu bu mesaj

 

[mkaraaslan]

klasör altındaki dosyaları kopyalama

arkadaşlar klasör içindeki çeşitli uzantılardaki dosyaları başka bir klasöre kopyalama istiyorum. şimdiye kadar bulduğum kodlar hep klasör kopyalama veya belirttiğiniz uzantılardaki dosyaları kopyalıyor. benim istediğim klasörün içindeki *.* dosyaları kopyalamak.
Not: Belirttiğim dizinde klasörlerde bulunduğu için klasör kopyalarken diğer klasörleride kopyalıyor.

 

[fyucel]

Kopyalama

Değerli Kardeşim, Dosyayı ekleyemedim ama
Aradınız komutları aşağıda bulabilirsiniz, mail adresi verirseniz Excel Dosyasını gönderebilirim.


Dim ds, dc, f, s, A, WKP, KSS
Sub SIRA_kontrol()

Dim X(50000, 4)
SON = Sheets("ADA_LISTE").[a65536].End(3).Row
For i = 2 To SON
X(i, 1) = Sheets("ADA_LISTE").Cells(i, 1)
If X(i, 1) = 0 Then X(i, 1) = X(i, 1) & "/" & Sheets("ADA_LISTE").Cells(i, 2)
X(i, 2) = Sheets("ADA_LISTE").Cells(i, 3)
X(i, 3) = Sheets("ADA_LISTE").Cells(i, 4)
X(i, 4) = Sheets("ADA_LISTE").Cells(i, 5)
Next

Sheets("ADA_LISTE").Range("C2:e50000").ClearContents

For J = 2 To SON
W = X(J, 1)
For L = 2 To SON
If X(L, 2) = W Then Sheets("ADA_LISTE").Cells(J, 3) = W
If X(L, 3) = W Then Sheets("ADA_LISTE").Cells(J, 4) = W
If X(L, 4) = W Then Sheets("ADA_LISTE").Cells(J, 5) = W
Next
Next
'MsgBox "bitti", , LOG

End Sub
Sub DosyaAdaRaporu()
Dim DOSYALAR As String, L As Integer
Sheets("ADA_LISTE").Select
Range("b1:b65000").ClearContents
Range("B1") = "AdaRap"
DOSYALAR = Dir$(Range("KLSR") & "\" & "*.docx")
Do While DOSYALAR <> ""
L = L + 1
WDS = DOSYALAR: N = InStr(WDS, ".")
Cells(L + 1, 2) = Left(WDS, N - 1)
DOSYALAR = Dir$()
Loop
Range("b2:b65000").Select
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("ANA").Select
MsgBox "Ada Raporları Listesi Alındı", , LOG

End Sub
Sub Kaynakklasor()
Sheets("ANA").Select
Range("E1:E3").ClearContents
KLSR = Range("KLSANA")
If Len(Dir(KLSR)) < 1 Then KLSR = "D:\"
ChDrive KLSR
ChDir KLSR

'ChDrive Range("KLSANA") & "\"
'ChDir Range("KLSANA") & "\"
WQ = "Kaynak Mahalle Klsaörünü Gösteriniz"
WOKU = Application.GetSaveAsFilename(WQ, fileFilter:="Mahalle Klasörünü Seçiniz (*.*), *.*")
If WOKU = False Then Exit Sub
For i = 1 To Len(WOKU)

If Mid(WOKU, i, 1) = "\" Then J = i
Next
Range("KLSANA") = Left(WOKU, J - 1)
Range("KLSR") = Left(WOKU, J) & "ADA_RAPORU"
Range("KLSK") = Left(WOKU, J) & "KROKI"
Range("KLSA") = Left(WOKU, J) & "ADALAR"
MsgBox "Dosyalar [" & Range("KLSANA") & "] Klasörü altındaki " & Chr(10) & "ADALAR" & Chr(10) & "ADA_RAPORU" & Chr(10) & "KROKI" & Chr(10) & "Klasörleri içinden alınacak", vbCritical, LOG

End Sub
Sub KOPYALA_ADARAPORU()
On Local Error Resume Next
Sheets("ADA_LISTE").Range("E2:E50000").ClearContents
Set ds = CreateObject("Scripting.FileSystemObject")
WKLSK = Range("KLSR") & "\"
WKRK = Dir$(WKLSK & "*.docx")
Do While WKRK <> ""
WDS = WKRK: WKOPY = WKLSK & WDS
L = L + 1: N = InStr(WDS, "."): D = InStr(WDS, "-")
If D = 0 Then
ADA = Left(WDS, N - 1)
U = U + 1: Sheets("ADA_LISTE").Cells(U + 1, 5) = ADA
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\")
Sheets("ADA_LISTE").Cells(U + 1, 5) = ADA
Else
ADA = 0: W = Replace(WKRK, ".docx", ""): deg = Split(W, "-")
For k = LBound(deg) + 1 To UBound(deg)
If IsDate(deg(k)) Then
Else
PAR = deg(k): U = U + 1
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\" & PAR & " PARSEL\")
Sheets("ADA_LISTE").Cells(U + 1, 5) = ADA & "/" & PAR
End If
Next
End If
WKRK = Dir$()
Loop
Sheets("ANA").Select
Range("e1") = U & " adet Klasör içine Ada Raporu Yedeklendi"
MsgBox Range("e1"), , LOG
End Sub

Sub KOPYALA_KROKI()
On Local Error Resume Next
Sheets("ADA_LISTE").Range("D250000").ClearContents
Set ds = CreateObject("Scripting.FileSystemObject")
WKLSK = Range("KLSK") & "\"
WKRK = Dir$(Range("KLSK") & "\" & "*.ncz")
Do While WKRK <> ""
WDS = WKRK: WKOPY = WKLSK & WDS
L = L + 1: N = InStr(WDS, "."): D = InStr(WDS, "-")
If D = 0 Then
ADA = Left(WDS, N - 1): U = U + 1
Sheets("ADA_LISTE").Cells(L + 1, 4) = ADA
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\" & ADA & "_Krk.NCZ")
Sheets("ADA_LISTE").Cells(U + 1, 4) = ADA
Else
ADA = 0: W = Replace(WKRK, ".NCZ", ""): deg = Split(W, "-")
For k = LBound(deg) + 1 To UBound(deg)
If IsDate(deg(k)) Then
Else
PAR = deg(k): U = U + 1
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\" & PAR & " PARSEL\" & W & "_Krk.NCZ")
Sheets("ADA_LISTE").Cells(U + 1, 4) = ADA & "/" & PAR
End If
Next
End If
WKRK = Dir$()
Loop
Sheets("ANA").Select
Range("e3") = U & " adet Klasör içine Kroki.ncz Yedeklendi"

MsgBox Range("e3"), , LOG
End Sub
Sub KOPYALA_ADALAR()
On Local Error Resume Next
Sheets("ADA_LISTE").Range("C2:C50000").ClearContents
Set ds = CreateObject("Scripting.FileSystemObject")
WKLSK = Range("KLSA") & "\"
WKRK = Dir$(Range("KLSA") & "\" & "*.ncz")

Do While WKRK <> ""
WKOPY = WKLSK & WKRK
L = L + 1: N = InStr(WKRK, "."): D = InStr(WKRK, "-")
If D = 0 Then
ADA = Left(WKRK, N - 1): U = U + 1: Sheets("ADA_LISTE").Cells(U + 1, 3) = ADA
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\")
Else
ADA = 0: W = Replace(WKRK, ".NCZ", ""): deg = Split(W, "-")
For k = LBound(deg) + 1 To UBound(deg)
If IsDate(deg(k)) Then
Else
PAR = deg(k): U = U + 1
f = ds.copyFile(WKOPY, Range("KLSH") & "\" & ADA & " ADA\" & PAR & " PARSEL\")
Sheets("ADA_LISTE").Cells(U + 1, 3) = ADA & "/" & PAR
End If
Next
End If
WKRK = Dir$()
Loop

Sheets("ANA").Select
Range("e2") = U & " adet Klasör Ada.ncz Yedeklendi"

MsgBox Range("e2"), , LOG

End Sub
Sub KOPYALA_TUMU()
On Local Error Resume Next
Set ds = CreateObject("Scripting.FileSystemObject")
A = ds.FolderExists(Range("KLSH") & "\ADALAR")
U = 0
If A = False Then
Z = MsgBox("Bazı Adaların Klasörü Yok Şimdi Oluşturulsunmu.? ", vbYesNo, LOG)
If Z = 6 Then KLASOR_OLUSTUR
End If
KOPYALA_ADARAPORU
KOPYALA_KROKI
KOPYALA_ADALAR
SIRA_kontrol
MsgBox Range("e1") & Chr(10) & Range("e2") & Chr(10) & Range("e3"), vbInformation, LOG
End Sub

Sub DosyaKroki()

Sheets("ADA_LISTE").Select
Range("d1:d65000").ClearContents
Range("d1") = "Adalar"

DOSYALAR = Dir$(Range("KLSA") & "\" & "*.ncz")
Do While DOSYALAR <> ""
L = L + 1
WDS = DOSYALAR: N = InStr(WDS, ".")
Cells(L + 1, 4) = Left(WDS, N - 1)
DOSYALAR = Dir$()
Loop
Range("D265000").Select
Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("ANA").Select
MsgBox "Kroki Listesi Alındı", , LOG
End Sub
Sub DosyaAdalar()
Sheets("ADA_LISTE").Select
Range("c1:c65000").ClearContents
Range("c1") = "Kroki"
DOSYALAR = Dir$(Range("KLSK") & "\" & "*.ncz")
Do While DOSYALAR <> ""
L = L + 1
WDS = DOSYALAR: N = InStr(WDS, ".")
Cells(L + 1, 3) = Left(WDS, N - 1)
DOSYALAR = Dir$()
Loop
Range("c2:c65000").Select
Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Sheets("ANA").Select
MsgBox "Kroki Listesi Alındı", , LOG
End Sub
Sub DosyaMahalleKlasoru()
Sheets("ANA").Select
Range("E1:E3").ClearContents
KLSR = "D:\"
If Len(Dir(KLSR)) < 1 Then KLSR = "D:\"
ChDrive KLSR
ChDir KLSR
WQ = "Hedef Mahale Klasörünü Gösteriniz"
WOKU = Application.GetSaveAsFilename(WQ, fileFilter:="Mahalle Klasörünü Seçiniz (*.*), *.*")
If WOKU = False Then Exit Sub
For i = 1 To Len(WOKU)
If Mid(WOKU, i, 1) = "\" Then J = i
Next
Range("KLSH") = Left(WOKU, J - 1)
A = MsgBox("Ada Klasörleri Oluşturulsunmu.? ", vbYesNo, LOG)
If A = 6 Then KLASOR_OLUSTUR: WKL = Range("KLSH") & " içinde ADA Klasörleri Oluşturuldu"

c = MsgBox(WKL & Chr(10) & "Yedekleme İşlemi Şimdi Yapılsınmı.? ", vbYesNo, LOG)
If c = 6 Then KOPYALA_TUMU
End Sub
Sub sil()
On Local Error Resume Next
WKLS = Range("KLSH") & "\": KK = 0
SON = Sheets("ADA_LISTE").[a65536].End(3).Row
Set ds = CreateObject("Scripting.FileSystemObject")
For i = 2 To SON

WKLY = Sheets("ADA_LISTE").Cells(i, 1): WKLYP = ""
If WKLY = 0 Then WP = Sheets("ADA_LISTE").Cells(i, 2): WKLYP = WP & " PARSEL\"
WDSY = WKLS & WKLY & " ADA\" & WKLYP
A = ds.FolderExists(WDSY)
If A = True Then
Kill WDSY & "\*.doc?"
Kill WDSY & "\*.NCZ"
KK = KK + 1
End If
Next
MsgBox KK & " adet Ada Klasörünün İçi Boşaltıldı", , LOG

End Sub
Sub KLASOR_OLUSTUR()
On Local Error Resume Next
WKLS = Range("KLSH") & "\": KK = 0
SON = Sheets("ADA_LISTE").[a65536].End(3).Row
Set ds = CreateObject("Scripting.FileSystemObject")

For i = 2 To SON
WD = Sheets("ADA_LISTE").Cells(i, 1): WE = "": s = 0
If WD = 0 Then
WE = "\" & Sheets("ADA_LISTE").Cells(i, 2) & " PARSEL": WKLSYZ = WKLS & WD & " ADA" & WE
s = ds.FolderExists(WKLSYZ)
End If
WKLSY = WKLS & WD & " ADA"
A = ds.FolderExists(WKLSY)
If A = True Then GoTo TMM
KK = KK + 1
ds.CreateFolder WKLSY
If WD = 0 Then
ds.CreateFolder WKLSYZ: KK = KK + 1
End If
TMM:
If WD = 0 Then If s <> True Then ds.CreateFolder WKLSYZ: KK = KK + 1
Next
If KK > 0 Then MsgBox KK & " adet Yeni Klasör Oluşturuldu", , LOG
End Sub
Sub TAPU_AL()
On Local Error Resume Next
Range("E1:E3").ClearContents
Application.ScreenUpdating = False
Sheets("KVK").Select
Cells.ClearContents

WDSY = ActiveWorkbook.Name
WKLL = Range("KLS")
If Range("KLS") = "" Then WKLL = "D:\"
ChDrive WKLL
ChDir WKLL

WOKU = Application.GetOpenFilename(fileFilter:="K.V.K. Excel Dosyaları (*.xls;*.xlsx;*.xlsm), *.xls;*.xlsx;*.xlsm")

If WOKU = False Then Exit Sub
WD$ = WOKU
T = InStr(WOKU, ".")
Z = Len(WOKU)
For J = Z To 1 Step -1
If Mid(WOKU, J, 1) = "." Then TT = Z - J: G = J
If Mid(WOKU, J, 1) = "\" Then GoTo TRM
Next

TRM:

WKLS = Left(WOKU, J - 1)
WDOS = Mid(WOKU, J + 1, Z - J)
WUZT = Right(WOKU, TT)
Range("DSY") = WDOS
Range("KLS") = WKLS

'***************
Workbooks.Open Filename:=WOKU
WDR = ActiveWorkbook.Name
Cells.Copy

Windows(WDSY).Activate
Sheets("KVK").Select

Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Windows(WDR).Activate

Application.CutCopyMode = False
ActiveWindow.Close

Columns("H:H").Select
Selection.Replace What:="--", Replacement:="0", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False

Columns("H:I").Cut
Range("A1").Select
ActiveSheet.Paste

SON = [a65536].End(3).Row
For i = 2 To SON
Cells(i, 1) = Val(Cells(i, 1))
Cells(i, 2) = Val(Cells(i, 2))
Next
Range("A1:B65000").Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2") _
, Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False _
, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal, DataOption2:= _
xlSortNormal
Application.ScreenUpdating = False
Range("A2").Select
SON = [a65536].End(3).Row


For i = SON To 2 Step -1
J = i - 1
If Cells(i, 1) <> 0 Then
If Cells(i, 1) = Cells(J, 1) Then
R = R + 1
Rows(i).Delete Shift:=xlUp
Cells(J, 2) = R
Else
R = 1
If i > 2 Then Cells(J, 2) = R
End If
End If
Next
Columns("C:X").ClearContents
Columns("a:b").Copy
Sheets("ADA_LISTE").Select
Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("C2:E5000").ClearContents
Range("B1") = "Parsel Adedi"
Sheets("ANA").Select
MsgBox "K.V.K. VERİLERİNE GÖRE ADA LİSTESİ HAZIRLANDI ", , LOG
End Sub

Function LOG()
LOG = " ** Faruk YÜCEL ** "
End Function
Function DosyaAdi() As String
Application.Volatile
DosyaAdi = Application.Caller.Parent.Parent.FullName
End Function
Sub Dosya_BUL()
Set f = ds.GetFolder(KSS)
Set dc = f.Files
For Each Dosya In dc
s = Dosya.Name
c = InStr(s, "-" & WKP)
If c > 0 Then Exit Sub
Next
s = ""
End Sub

 

[halit3]

arkadaşlar klasör içindeki çeşitli uzantılardaki dosyaları başka bir klasöre kopyalama istiyorum. şimdiye kadar bulduğum kodlar hep klasör kopyalama veya belirttiğiniz uzantılardaki dosyaları kopyalıyor. benim istediğim klasörün içindeki *.* dosyaları kopyalamak.
Not: Belirttiğim dizinde klasörlerde bulunduğu için klasör kopyalarken diğer klasörleride kopyalıyor.

kod:

Dim Kaynak2

Sub Dosyaları_kopyala()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla1

Set Klasor2 = CreateObject("shell.application").BrowseForFolder(0, "Hedef Klasörü Seçin", 50, &H0)
If Not Klasor2 Is Nothing Then
Kaynak2 = Klasor2.self.Path
If InStr(1, Kaynak2, "{") > 0 Then GoTo Atla2

Liste (Kaynak)
Set Klasor2 = Nothing

MsgBox "işlem tamam"
Else
Atla2:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If

Set Klasor = Nothing

Else
Atla1:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object
Set fL = CreateObject("Scripting.FileSystemObject")

If Right(yol, 1) <> "\" Then ekle = "\"
For Each Dosya In fL.GetFolder(yol).Files
eski = fL.GetFile(Dosya)
yeni = Kaynak2 & "\" & fL.GetFileName(Dosya)
FileCopy eski, yeni
Next

On Error GoTo sonraki
For Each f In fL.GetFolder(yol).subfolders
Liste (f.Path)
sonraki:
Next

End Sub

 

[emrozkn]

Halit hocam yeni konu açmakla buraya yazmak arasında tereddütte kaldım ama bu konuya çok yakın olduğu için buraya yazıyorum.

Bir excel dosyasında öğrenci numaralarının olduğu bir veri var(800 adet). Ayrıca bir klasörde yaklaşık 3000 fotoğraf dosyası var. Makro ile bu excel dosyasında olan öğrencilerin fotoğraflarını klasörden eşleştirip fotoğrafları başka bir klasöre kopyalayacak bir koda ihtiyacım var.
Klasörde kayıtlı olan fotoğraflar öğrenci numaraları ile kaydedilmiş durumda.

Örnek olarak "liste" isimli excel dosyasının Sayfa 1 sekmesinin A1 ile A800 arasında öğrenci numaraları kayıtlı. D\foto klasörü içerisinde de bu öğrenci numaraları isimleriyle kayıtlı jpeg formatlı resimler var.

Yardımcı olabilirseniz çok memnun olurum.

 

[halit3]

Halit hocam yeni konu açmakla buraya yazmak arasında tereddütte kaldım ama bu konuya çok yakın olduğu için buraya yazıyorum.

Bir excel dosyasında öğrenci numaralarının olduğu bir veri var(800 adet). Ayrıca bir klasörde yaklaşık 3000 fotoğraf dosyası var. Makro ile bu excel dosyasında olan öğrencilerin fotoğraflarını klasörden eşleştirip fotoğrafları başka bir klasöre kopyalayacak bir koda ihtiyacım var.
Klasörde kayıtlı olan fotoğraflar öğrenci numaraları ile kaydedilmiş durumda.

Örnek olarak "liste" isimli excel dosyasının Sayfa 1 sekmesinin A1 ile A800 arasında öğrenci numaraları kayıtlı. D\foto klasörü içerisinde de bu öğrenci numaraları isimleriyle kayıtlı jpeg formatlı resimler var.

Yardımcı olabilirseniz çok memnun olurum.

kod:

Sub Dosyaları_kopyala()

Dim fL As Object
Set fL = CreateObject("Scripting.FileSystemObject")


Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Hedef resimlerin kopyalanacağı Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.self.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla1

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"
ReDim uzanti(6)
uzanti(1) = ".JPG"
uzanti(2) = ".jpg"
uzanti(3) = ".BMP"
uzanti(4) = ".bmp"
uzanti(5) = ".GİF"
uzanti(6) = ".gif"

yol = "C:\foto\" ' resimlerin bulunduğu dosya yolu
For i = 1 To Cells(Rows.Count, "A").End(3).Row
aranan1 = Cells(i, "A").Value
If aranan1 <> "" Then
For j = 1 To 6
Dosya = yol & aranan1 & uzanti(j)

If fL.FileExists(Dosya) = True Then
yeni = Kaynak & "\" & fL.GetFileName(Dosya)
FileCopy Dosya, yeni
Exit For
End If

Next
End If
Next

MsgBox "işlem tamam"
Set Klasor = Nothing
Else
Atla1:
MsgBox "Lütfen Hedef Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub

 

[mustilem23]

Halit hocam ,

kodlama ile belirli bir klasör de outlook da ilet dediğim pencere açık iken konu kısmındaki (y2000%) başlayan yazı kopyalayıp klasörden bulunan y2000%.pdf dosyasını kopyalatıp outlook ilet açık olan emaile kopyalatabilmek mümkün müdür.