Przesunięty przez: Tajan
24-01-2023, 14:31 |
Kopiowanie plików na podstawie wartości komórki |
| Autor |
Wiadomość |
MMriuSS 
Fan Excela
Posty: 92
|
 Wysłany: 24-01-2023, 10:40 Kopiowanie plików na podstawie wartości komórki
|
|
|
Witam!
Mam kod, który kopiuje pliki, jeżeli w nazwie jest słowo "Komunikat":
| Kod: |
Sub KopiujPlikiPomiedzyFolderami()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("E:\X\")
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
If InStr(1, objFile.Name, "Komunikat") > 0 Then
objFSO.CopyFile objFile, "E:\Y\"
End If
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub
|
Pomimo wielu prób nie wiem, jak go przerobić, żeby kopiował plik na podstawie wartości w komórce A1.
Z góry dziękuję za pomoc i wskazówki.
Pozdrawiam |
|
 | ID posta:
424525
|
|
|
 |
|
|
|
|
Tajan
Pomógł: 5234 razy
Posty: 11412
|
| Wysłany: 24-01-2023, 11:27
|
|
|
Można tak:
| Kod: | | If InStr(1, objFile.Name, Range("A1").Value) > 0 Then |
Przedtem dobrze byłoby sprawdzić, czy komórka A1 nie jest pusta, np.:
| Kod: | | If Range("A1").Value = "" Then Exit Sub |
|
|
 | ID posta:
424538
|
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 11:37
|
|
|
| Tajan napisał/a: | Można tak:
| Kod: | | If InStr(1, objFile.Name, Range("A1").Value) > 0 Then |
|
Dzięki za zainteresowanie, ale polecenie
| Kod: | | If InStr(1, objFile.Name, Range("A1").Value) > 0 Then |
w dalszym ciągu odnosi się do nazwy pliku, a mnie chodzi o to, żeby kod dotarł do
w każdym pliku i jeżeli
| Kod: | | Range("A1").Value = "X" |
to wówczas nastąpi kopiowanie pliku do nowej lokalizacji. |
|
| ID posta:
424539
|
|
|
|
|
|
Tajan
Pomógł: 5234 razy
Posty: 11412
|
| Wysłany: 24-01-2023, 11:45
|
|
|
| Pytanie było nieprecyzyjne. Zresztą, nadal jest. Skoro sprawdzamy komórkę, to należy określić z jakiego arkusza. Czy bierzemy pod uwagę jakąś nazwę, czy tylko jego położenie w pliku- czyli np. 1? |
|
| ID posta:
424541
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 11:53
|
|
|
Sorki, może rzeczywiście użyłem skrótów myślowych. W każdym pliku jest jeden arkusz załóżmy, że nazywa się "Arkusz1". W przypadku otwarcia pliku zawsze będzie miał status ActiveSheet. W kodzie nie bierzemy pod uwagę nazwy arkusza. Coś w tym stylu:
| Kod: | Workbook.Open
If ActiveSheet.Range("A1").Value = "a" Then Workbook.Copy do ścieżki "E:\Y\" |
|
|
| ID posta:
424542
|
|
|
|
|
|
Tajan
Pomógł: 5234 razy
Posty: 11412
|
| Wysłany: 24-01-2023, 12:17
|
|
|
To może tak:
| Kod: | Sub KopiujPlikiPomiedzyFolderami()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim toCopy As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("E:\X\")
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
If LCase(objFile.Name) Like "*.xl?*" Then
With Workbooks.Open(objFile.Path)
If .Sheets(1).Range("A1").Value = "Szukana wartość" Then
.SaveCopyAs "E:\Y\" & objFile.Name
End If
.Close
End With
End If
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub
|
|
|
| ID posta:
424545
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 12:42
|
|
|
Coś nie chce mi działać.
Musimy badać, czy plik ma rozszerzenie .xls/xlsx?
| Kod: | | If LCase(objFile.Name) Like "*.xl?*" Then |
Moje pliki są plikami .csv
Tu chyba w dalszym ciągu odnosimy się do nazwy pliku (objFile.Name)?
Zmieniłem "*.xl?*" na "*.cs?*" oraz "objFile.Name" na "objFile" oraz ".Sheets(1).Range("A1")" na "ActiveSheet.Range("A1")" ale nie działa.
Arkusze mają różne nazwy i musimy się odwoływać do aktywnego arkusza.
| Kod: | | .SaveCopyAs "E:\Y\" & objFile.Name |
|
|
| ID posta:
424546
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 12:57
|
|
|
Pobawiłem się trochę kodem i już wiem, że przyczyną jest prawdopodobnie format pliku .csv
Przy plikach .xlsx kod działa świetnie. Dzięki Tajan o to chodziło. A jak zrobić, żeby to działało na pliki.csv? |
|
| ID posta:
424547
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 13:01
|
|
|
Tak to wygląda:
| Kod: | Sub KopiujPlikiPomiedzyFolderami()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim toCopy As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("E:\A\")
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
If LCase(objFile.Name) Like "*.xl?*" Then
With Workbooks.Open(objFile.Path)
If .ActiveSheet.Range("A1").Value = "DATA_OD" Then
.SaveCopyAs "E:\AAA\" & objFile.Name
End If
.Close
End With
End If
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub
|
Zmieniłem odniesienie na ActiveSheet |
|
| ID posta:
424548
|
|
|
|
|
|
Tajan
Pomógł: 5234 razy
Posty: 11412
|
| Wysłany: 24-01-2023, 13:26
|
|
|
Ja nie wiem ja nie wiem jakie pliki masz w tym folderze, więc uznałem, ze chodzi o skoroszyty Excela. Ale skoro to pliki csv to należy zastosować inne podejście. Przydałby się przykładowy plik csv oraz przykład tekstu, który ma być porównany z plikiem, bo być może tu tkwi problem.
Spróbuj tak:
| Kod: | Sub KopiujPlikiPomiedzyFolderami()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim toCopy As Boolean
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFSO.GetFolder("E:\X\")
Application.ScreenUpdating = False
For Each objFile In objFolder.Files
If objFSO.GetExtensionName(objFile) = "csv" Then
With Workbooks.Open(objFile)
toCopy = (.Sheets(1).Range("A1").Value = "TEXT DO WYSZUKANIA")
.Close False
End With
If toCopy Then objFSO.CopyFile objFile, "E:\Y\"
End If
Next
'Clean up!
Set objFolder = Nothing
Set objFile = Nothing
Set objFSO = Nothing
Application.ScreenUpdating = True
End Sub
|
Skoro arkusze mają różne nazwy, to odwołanie do pierwszego (Sheets(1)) powinno być zawsze OK. |
|
| ID posta:
424549
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 13:42
|
|
|
Proszę bardzo, uprzejmie przesyłam plik :)
Chodzi mi o tekst z komórki A1 "DATA_OD"
test.csv
|
 Pobierz Plik ściągnięto 8 raz(y) 85 Bajtów |
|
|
| ID posta:
424553
|
|
|
|
|
|
Tajan
Pomógł: 5234 razy
Posty: 11412
|
| Wysłany: 24-01-2023, 14:04
|
|
|
No, nie wiem... Powyższe makro powinno działać. A spróbuj zamienić:
| Kod: | | toCopy = (.Sheets(1).Range("A1").Value = "TEXT DO WYSZUKANIA") |
na:
| Kod: | | toCopy = InStr(1, .Sheets(1).Range("A1").Value, "DATA_OD") > 0 |
|
|
| ID posta:
424555
|
|
|
|
|
|
MMriuSS
Fan Excela
Posty: 92
|
| Wysłany: 24-01-2023, 14:19
|
|
|
D Z I A Ł A !!!!!
 
Tajan, bardzo Ci dziękuję za pomoc, pozdrawiam serdecznie |
|
| ID posta:
424558
|
|
|
|
|
|
|
|
Regulamin
