MS Excel

Téma: Excel a úprava dokumentů

Zaslal/a MartinFF 23.1.2025 12:38

Ahoj, potřeboval bych poradit. Potřebuji v 1800 dokumentech vyhledat text v jedné složené buňce a smazat jej. Za boha se mi to nedaří. můžete se mi mrknout na makro, kde tam mám chybu ? Díky za každou radu... dělat to 1800 je na smrt ;)

Sub UpdateExcelFilesUsingFSO()
Dim FolderPath As String
Dim FSO As Object
Dim Folder As Object
Dim File As Object

' Kořenová složka
FolderPath = "C:\Mac\Home\Desktop\QI\QI\Makina\"
Set FSO = CreateObject("Scripting.FileSystemObject")

' Získání kořenové složky
On Error Resume Next
Set Folder = FSO.GetFolder(FolderPath)
If Folder Is Nothing Then
MsgBox "Cesta k adresáři není platná.", vbCritical
Exit Sub
End If
On Error GoTo 0

' Procházení všech souborů ve složce a podsložkách
Debug.Print "Začátek úprav souborů..."
ProcessFilesAndSubfolders Folder
MsgBox "Úpravy dokončeny. Zkontrolujte soubory.", vbInformation
End Sub

Sub ProcessFilesAndSubfolders(Folder As Object)
Dim File As Object
Dim SubFolder As Object
Dim Workbook As Workbook
Dim Worksheet As Worksheet
Dim ChangeMade As Boolean

' Procházení souborů v aktuální složce
For Each File In Folder.Files
If InStr(File.Name, ".xls") > 0 Then
Debug.Print "Zpracovává se soubor: " & File.Path
On Error Resume Next
Set Workbook = Workbooks.Open(File.Path)
On Error GoTo 0

If Not Workbook Is Nothing Then
ChangeMade = False

' Iterace přes všechny listy v souboru
For Each Worksheet In Workbook.Sheets
Dim SearchRange As Range
Dim Cell As Range
Dim MergedCell As Range

' Nastavení oblasti hledání na celý list
Set SearchRange = Worksheet.UsedRange

' Prohledání oblasti pro text obsahující "Visual"
For Each Cell In SearchRange
If Cell.MergeCells Then
With Cell.MergeArea
If Not IsEmpty(.Value) And Not IsError(.Value) And VarType(.Value) = vbString Then
If InStr(1, .Value, "Visual", vbTextCompare) > 0 Then
' Najdi sloučenou buňku o jeden řádek níže
Set MergedCell = Worksheet.Cells(.Row + .Rows.Count, .Column)
If MergedCell.MergeCells Then
MergedCell.MergeArea.Value = "" ' Vymazání obsahu
ChangeMade = True
Exit For
End If
End If
End If
End With
End If
Next Cell
Next Worksheet

' Uložení změn
If ChangeMade Then
Workbook.Close SaveChanges:=True
Debug.Print "Změny uloženy: " & File.Path
Else
Workbook.Close SaveChanges:=False
Debug.Print "Žádné změny nebyly nutné: " & File.Path
End If
End If
End If
Next File

' Rekurzivní zpracování podsložek
For Each SubFolder In Folder.SubFolders
Debug.Print "Procházení podsložky: " & SubFolder.Path
ProcessFilesAndSubfolders SubFolder
Next SubFolder
End Sub

Zaslat odpověď >

elninoslov(24.1.2025 8:48)#057196

Ak to vydrží do poobedia, spravím. Už to mám zväčša premyslené. Ešte domyslím logovanie (ide o úpravu súborov, log je dôležitý). Len čakám servisáka a musím si robiť nejakú prípravu tak nie je čas ...
Môže sa ten hľadaný text nachádzať v liste viackrát? Ak áno, treba kontrolovať/nahradiť všetky výskyty?citovat

MartinFF(24.1.2025 8:58)#057197

Ahoj, právě že se může vyskytovat víckrát na více listech a potřebuji nahradit všechny výskyty :)citovat

elninoslov(24.1.2025 23:33)#057198

!!! Skúšajte to VÝHRADNE NA KÓPII nejakej časti z tých súborov !!!

Nakopírujte si ich do nejakého skúšobného adresára.
Loguje a ošetruje to spústu stavov. Použil som novú inštanciu Excelu, a je to oveľa rýchlejšie, ale pozor, ak by ste pri debugovaní ukončil makro, ostane inštancia visieť, a treba ju manuálne ukončiť v správcovi procesov.
Dajte vedieť.

Příloha: zip

57198_hromadna-zmena.zip (403kB, staženo 2x)

citovat

Uživatelské menu

Nejste přihlášen(a)

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.