Makro för att radera specifikt definierat namn, med villkor, i flera filer samtidigt.

[Mikael63]

En egen frågeställning men är intimt sammanlänkad till denna: https://www.alltomwindows.se/topic/33921-namnkonflikt/#comment-244893

 

Jag behöver (verkligen) ett makro som antingen söker alla Excelfiler inom en viss (i koden fast namngiven) katalog med egna underkataloger eller möjligen, om det går och anses säkert, att koden körs för varje arbetsbok som öppnas.

Jag vill ta bort det definierade namnet Utskriftsområde OM namnet Print_Area finns, samt (oavsett föregående) ta bort namnet Utskriftsrubriker OM namnet Print_Titles finns.

Just nu är jag klar med dessa "körningar" och möjligen kommer en leverantör/utvecklare(?) av en mjukvara *) att komma med en lösning - men tills dess, tills nästa gång, vore det alltså bra med ett sådant makro! 

*) det är denna mjukvara som stökar till det genom att lägga till det engelska namnen 🤬

 

Tillägg:

Det går kanske inte att lösa detta med villkoret kom jag på... Excel tolkar ju Print_Area som Utskriftsområde vilket innebär att villkoret kommer att vara sant oavsett...

Redigerad Juli 4, 2023 av Mikael63

[Mikael63]

Okej, nu har jag bytt språk, i Office, till Engelska UK (Engelska US "tog" inte, av någon anledning).
Nu får jag samma felmeddelande som i  https://www.alltomwindows.se/topic/33921-namnkonflikt/#comment-244893 så fort jag försöker öppna en fil, med Excel. Nu vet jag ju vad det beror på varför jag har tragglat igenom *) alla mina 112 filer (öppnat, bytt namn, bytt namn, sparat) varför det vid nästa "körning inte torde uppstå problem. OM ingen med Svenskt Office öppnat och ändrat i filerna förstås...

*) Här är det bra med ett makrotangentbord!

[MH_]

Öppnade filen du hade lagt i den andra tråden. Jag får inga fel så jag vet inte riktigt vad som blir stökigt.

Men:

Alla utskriftområden (oavsett språk) får en begränsad räckvidd (bladet). Om du vill radera ett sånt område tror jag att du måste ställa dig i det bladet först. Typ:

    Sheets("UCA001").Select
    ActiveWorkbook.Names("Print_Area").Delete

Eller, det verkar även funka att hänvisa till 'UCA001'!Print_Area

ActiveWorkbook.Names("'UCA001'!Print_Area").Delete

Hmm, eller inte. i din exempelfil så har du två print titles.  I excel ger Ctrl+F3 två områden: utskriftsrubriker och Print_Titles. 

Men om du kör den här loopen så "ser" VBA båda områdena som "'UCA001'!Print_Titles"  (lista i direktfönstret)

Sub xxx()
Dim namn As Name
    For Each namn In ActiveWorkbook.Names
        Debug.Print (namn.Name)
    Next namn
End Sub

Men, koden:

ActiveWorkbook.Names("'UCA001'!Print_Titles").Delete

tar bara bort den ena...

 

*****************************************************************************************************************************

Ähh, testa något i den här stilen. Letar igenom alla namn. Om namnet innehåller ordet "Print_Area" så raderas det : 

Sub test()
Dim namn As Name
    For Each namn In ActiveWorkbook.Names
        If InStr(namn.Name, "Print_Area") > 0 Then
            namn.Delete
        End If
    Next namn
End Sub

Det borde funka även om det finns "Print_Area" i olika blad. VBA sköter ju adresseringen själv så du behöver inte bry dig.

 

Och om du vill radera både area och Titles:

Sub test2()
Dim namn As Name
    For Each namn In ActiveWorkbook.Names
        If ((InStr(namn.Name, "Print_Area") > 0) Or (InStr(namn.Name, "Print_Titles") > 0)) Then
            namn.Delete
        End If
    Next namn
End Sub

Inspirerat av:

excel - Delete specific name ranges using vba - Stack Overflow

Redigerad Juli 5, 2023 av MH_

[MH_]

Ahhh, och de svenska namnen får du med "NameLocal"

 

Sub swe()
Dim namn As Name
    For Each namn In ActiveWorkbook.Names
        Debug.Print (namn.NameLocal)
    Next namn
End Sub

 

Då borde du kunna ställa upp dina villkor så att det blir precis som du vill

 

[Mikael63]

Tack!

När jag testade lite på egen hand hade jag bara

    On Error Resume Next
    If ActiveWorkbook.Names("Print_Area") Then
    ActiveWorkbook.Names("Utskriftsområde").Delete
    End If
    If ActiveWorkbook.Names("Print_Titles") Then
    ActiveWorkbook.Names("Utskriftsrubriker").Delete
    End If

Det fungerade men resultatet blev att Utskriftsområde togs bort och vid nästa körning av makrot togs även Print_Area bort eftersom Excel tyckte att det var det jag ville göra.

Alla mina 112 filer innehåller Utskriftsområde/Print_Area och nästan alla (men det borde vara alla) innehåller även Utskriftsrubriker/Print Titles.

Så snart man behöver justera utskriftsområdet, vilket man behöver göra då och då beroende på vald skrivare och på en känd bugg i ett insticksprogram som (också) läser dessa filer, så skapas namnet Utskriftsområde, om det inte redan fanns, när man använder svensk Excel.

Den här mjukvaran, "AFR", tycks på något sätt nyttja den engelska versionen av Excel och när den mjukvaran behöver skriva till filen omvandlas Utskriftsområde till Print_Area.
(Namnet Utskriftsområde tas bort, eller döps om)
Det påverkar inget om man senare öppnar filen med svenskt Excel men så fort man justerar Utskriftsområdet kommer namnet Utskriftsområde att skapas och ligger tillsammans med Print_Areas. Det går fortfarande bra att öppna filen med Svenskt Excel.

När så AFR, som använder engelskt Excel, eller någon annan som använder engelsk Excel, försöker öppna en sådan fil uppstår den här namnkonflikten. Min tanke var således att ta bort enbart den ena av dem och då i alla dessa 112 men bara om de innehåller båda varianterna. Alla filer har bara ett blad.

Jag antar att jag behöver byta tillbaks till svenskt Excel för att fortsätta att testa.

Jag hade/har visserligen några gamla filer men det blir samma sak om man skapar en helt ny fil.

[MH_]

Då får du väl köra en snurra som räknar antalet "Print_Titles" och radera det som heter "Utskriftsrubriker" när man kör lokala namn:

 

Sub radera_Utskriftsrubriker()
Dim namn As Name
Dim PTcount As Integer
PTcount = 0
    For Each namn In ActiveWorkbook.Names
        If (InStr(namn.Name, "Print_Titles") > 0) Then
            PTcount = PTcount + 1
        End If
    Next namn
If PTcount > 1 Then
    For Each namn In ActiveWorkbook.Names
        If (InStr(namn.NameLocal, "Utskriftsrubriker") > 0) Then
            namn.Delete
        End If
    Next namn
End If

End Sub

 

MEN. i rimlighetens namn är det det område som döps om till det lokala namnet som är "Riktigt". Det område som kallas "Print_Titles" oavsett språk borde vara något som excel inte känner igen som "Print_Titles"

 

+ du behöver eventuellt köra det här för varje enskilt blad eftersom du faktiskt kan ha en "Print_Titles" i varje blad

[MH_]

japp.

kolla med

Sub test()
MsgBox ActiveSheet.PageSetup.PrintArea
MsgBox ActiveSheet.PageSetup.PrintTitleRows
End Sub

Så ser du att det område som heter  Print_Area  när du kör .NameLocal inte är ett Print_Area "på riktigt". det andra känns inte igen som en "riktig"  PrintArea

Dvs den som skapade utskriftsområdet har bara gett ett område namnet "Print_Area". Inte skapat det med hjälp av PageSetup

 

Testa så här (bara print_title)

• Gå igenom varje blad.
• Kolla om ett namn innehåller "Print_Titles".  Om så:
  • spara adressen
  • ta bort området
  • skapa printTitle genom att sätta PageSetup.PrintTitleRows=adressen
• Nästa blad

Sub tjoflöjt()
Dim WS As Worksheet
Dim namn As Name
Dim adress As String
For Each WS In ActiveWorkbook.Worksheets
    For Each namn In WS.Names
            If (InStr(namn.Name, "Print_Titles") > 0) Then
                adress = namn.RefersTo
                namn.Delete
                WS.PageSetup.PrintTitleRows = adress
            End If
    Next namn
Next WS
End Sub

Då kommer du bara att ha ett "Print_Title" för varje blad. Och det känns igen av excel så det borde inte skapas några nya om du jobbar manuellt

 

Lägg in en IF för "Print_Area" också

Sub tjoflöjt()
Dim WS As Worksheet
Dim namn As Name
Dim adress As String
For Each WS In ActiveWorkbook.Worksheets
    For Each namn In WS.Names
    
            If (InStr(namn.Name, "Print_Titles") > 0) Then
                adress = namn.RefersTo
                namn.Delete
                WS.PageSetup.PrintTitleRows = adress
            End If
    
            If (InStr(namn.Name, "Print_Area") > 0) Then
                adress = namn.RefersTo
                namn.Delete
                WS.PageSetup.PrintArea = adress
            End If
    Next namn
    
Next WS
End Sub

 

Peta in det i någon snurra som letar efter rätt workbooks

[Mikael63]

Bytte till svenskt språk i Excel.
Öppnade en av mina skarpa filer (backup av)
Kollade och det fanns massor med namn, alla på svenska.

Körde koden längst ner i föregående inlägg, haltade på
 

If (InStr(namn.Name, "Print_Area") > 0) Then

Jag lade då in så att

On Error Resume Next
If (InStr(namn.Name, "Print_Area") > 0) Then

Då fick jag inget felmeddelande men utskriftsområdet togs bort, dock inte namnet Utskriftsområde

 

60003.xlsx

[MH_]

det är för att jag är dum i huvudet.

Om man kör "namn.Delete"  i första IF-satsen så finns den inte kvar när man kör nästa IF-sats....

[MH_]

Sub tjoflöjt()
Dim WS As Worksheet
Dim namn As Name
Dim adress As String
For Each WS In ActiveWorkbook.Worksheets
    For Each namn In WS.Names
    
            If ((InStr(namn.Name, "Print_Area") > 0) Or (InStr(namn.Name, "Print_Titles") > 0)) Then
                adress = namn.RefersTo
                    If (InStr(namn.Name, "Print_Area") > 0) Then
                        namn.Delete
                        WS.PageSetup.PrintArea = adress
                    ElseIf (InStr(namn.Name, "Print_Titles") > 0) Then
                        namn.Delete
                        WS.PageSetup.PrintTitleRows = adress
                    End If
            End If
    Next namn
Next WS
End Sub

då kommer Utskriftsområde och Utskriftsrubriker finnas kvar medan de namngivna "Print_Area" och "Print_Titles" försvinner (omvandlas till Utskriftsområde/Utskriftsrubriker på svenska).

Kolla de här paren med svenska/VBA namn före/efter rensningen

Sub namn()
Dim namn As Name
    For Each namn In ActiveWorkbook.Names
        Debug.Print (namn.NameLocal & Chr(10) & namn.Name & Chr(10))
    Next namn
End Sub

 

****ED***

Dvs de kvarvarande områdena kommer att ha namnpar som ser ut så här: 

Ändringshistorik!Utskriftsområde
Ändringshistorik!Print_Area

Ändringshistorik!Utskriftsrubriker
Ändringshistorik!Print_Titles

Redigerad Juli 6, 2023 av MH_

[Mikael63]

TACK!

Jag har nu testat detta enligt följande (mest som en egen notering):

1 Öppna filen med Excel (svenskt språk, även fortsättningsvis), justera utskriftsområdet
2 Spara och öppna på nytt. OK
3 "Köra AFR" - tar stopp.
4 Öppna filen på nytt, kör "tjoflöjt", sparar.
5 "Köra AFR" - OK
6 Öppnar med Excel - OK
7 Upprepar stegen ovan - OK
8 Kör "tjoflöjt" upprepade gånger (för att se om det skulle tas bort för mycket) - OK

Slutsatsen är att detta fungerar alldeles lysande! Inget behov av att ändra språk med risk för att filen justeras senare med "fel" språk.
Filerna behöver "bara" rensas före varje körning av AFR, och endast då, och det är ett väldigt litet "omak" i jämförelse med i princip allt annat som detta handlar om.

Här skulle då detta behövas:

On 2023-07-04 at 21:55, Mikael63 sade:

söker alla Excelfiler inom en viss (i koden fast namngiven) katalog med egna underkataloger

Alltså att jag bestämmer sökvägen "fast" i koden som ex G:\ABCD\EFGH\IJKL\MNO och där alla "underliggande" excelfiler får sig en duvning av "tjoflöjt"
Makrot har jag i Personal.xlsb och en knapp i en egen ribbon   varför jag kan komma åt att köra den från valfri eller tom arbetsbok.

 

Jag HAR försök klura ut detta genom att kika i andra makron som @MH_ och @Monshi har grejat åt mig men får inte till en snygg lösning för det 

Redigerad Juli 6, 2023 av Mikael63

[MH_]

Om man snor din gamla kod som ni använde tidigare. Ttroligtvis baserad på det här: 

https://exceloffthegrid.com/vba-code-loop-files-folder-sub-folders/

Så borde något i den här stilen funka.

 

Option Explicit

Sub start()
Dim startmapp As String
 
    Dim folder As String
    folder = GetFolder

Call LoopAllSubFolders(folder)

End Sub


Function GetFolder() As String
    Dim fldr As FileDialog
    Dim sItem As String
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        .InitialFileName = Application.DefaultFilePath
        If .Show <> -1 Then GoTo NextCode
        sItem = .SelectedItems(1)
    End With
NextCode:
    GetFolder = sItem
    Set fldr = Nothing
End Function





Sub LoopAllSubFolders(ByVal folderPath As String)

Dim fileName As String
Dim fullFilePath As String
Dim numFolders As Long
Dim folders() As String
Dim i As Long

If Right(folderPath, 1) <> "\" Then folderPath = folderPath & "\"
fileName = Dir(folderPath & "*.*", vbDirectory)

While Len(fileName) <> 0

    If Left(fileName, 1) <> "." Then
 
        fullFilePath = folderPath & fileName
 
        If (GetAttr(fullFilePath) And vbDirectory) = vbDirectory Then
            ReDim Preserve folders(0 To numFolders) As String
            folders(numFolders) = fullFilePath
            numFolders = numFolders + 1
        ElseIf (InStr(1, fileName, ".xl") > 0) Then
            Call tjoflöjt(folderPath & fileName, fileName)
        End If
 
    End If
 
    fileName = Dir()

Wend

For i = 0 To numFolders - 1

    LoopAllSubFolders folders(i)
 
Next i

End Sub

Sub tjoflöjt(sökväg, filnamn)
Dim WS As Worksheet
Dim namn As Name
Dim adress As String
'Öppna filen
Workbooks.Open sökväg

For Each WS In ActiveWorkbook.Worksheets
    For Each namn In WS.Names
    
            If ((InStr(namn.Name, "Print_Area") > 0) Or (InStr(namn.Name, "Print_Titles") > 0)) Then
                adress = namn.RefersTo
                    If (InStr(namn.Name, "Print_Area") > 0) Then
                        namn.Delete
                        WS.PageSetup.PrintArea = adress
                    ElseIf (InStr(namn.Name, "Print_Titles") > 0) Then
                        namn.Delete
                        WS.PageSetup.PrintTitleRows = adress
                    End If
            End If
    Next namn
Next WS
'Spara och stäng (den vill inte ha sökvägen då)
Workbooks(filnamn).Close SaveChanges:=True
End Sub

 

OBS Jag har bara testat med testat med att låta "tjoflöjt" öppna/stänga filerna och visa filnamnen. 

Sub tjoflöjt(sökväg, filnamn)
    Workbooks.Open sökväg
    MsgBox sökväg
    Workbooks(filnamn).Close SaveChanges:=True
End Sub

Men det borde funka ändå

[Mikael63]

Tack!

Jo den fungerade fint men det verkar som att det inte riktigt lirar hela vägen, någonstans... Jo snurran att ta alla filer fungerar men..  jag testar med fem av de skarpa filerna och det verkar som att första gången (på filer som sparats senast med den engelskspråkiga Excel)  makrot körs ändras utskriftsområdet till att vara så långt ner där det finns värden i cellerna. Det kan jag leva med, att en gång justera detta.

Sedan jag justerat utskriftsområdena, kört snurran och kör en testomgång med AFR (som då inte bråkar eftersom makrot har städat) och därefter öppnar med Excel kan det se ut så här:

 

Det synliga området har här ändrats till att vara där sista raden med värde finns. Namnhanteraren anger annan rad och rad 44 var det när jag sparade filen.
Så blir det alltså för fyra av fem filer, den femte filen var inställd  så att rad 53 var den sista, text finns i rad 30, efteråt är det rad 50 som är sist?

Kanske lite för mycket mekanismer bakom detta?

 

 

[Mikael63]

1 timme sedan, Mikael63 sade:

Kanske lite för mycket mekanismer bakom detta?

Hm.. kanske bara är så att jag måste köra skriptet av @MH_

en gång till? Alltså först köra det för att inte AFR ska gnälla som en xxxx och sen en gång till för att inte jag ska gnälla som en xxxx för att sidlayouten är sabbad?
 

Behöver testa och "bokföra" detta lite strukturerat, kan kanske hända att jag återkommer.. 😁

[MH_]

Eftersom tjoflöjt körs på alla förekomster av "Print_Area" så är det förmodligen bara så att det namngivna område som kommer senare i lista "vinner" och får bestämma vad utskriftsområdret blir.

Du skulle kunna bygga en räknare och bara använda den äldsta eller något liknande (jag antar att namngivna 8mråd3n kommer 7 datum8rdning)

Jag haaaaatar telefontamgentbord

[Mikael63]

Nä det får duga som det är, jag fattar inte riktigt vad som händer här!

Av de fem jag testade var det en fil, vi kan kalla den nummer 8, som avvek från mönstret.

Jag rensade testmappen och kopierade in 2x8 andra skarpa filer och jo, det tycktes vara något speciellt med "åttan". Kopierade in dem på nytt tillsammans med de åtta filer där de första fem ingick. Körde start (måste komma ihåg att döpa om den kanske..)/tjoflöjt på alla dessa 3x8 filer. Öppnade i Excel och justerade möjligen någon. Ny körning av start/tjoflöjt direkt följt av en körning med AFR direkt följt av en körning med start/tjoflöjt.

Inte f-n var det någon som var knepig nu inte? inte ens "åttan"?

Har jag tur (vilket jag inte brukar ha i dessa sammanhang) behöver jag inte hålla på så med de 112 filerna igen. Möjligen med 14 av dem (och det råkar faktiskt vara åttan i så fall!)

 

Jag kan förklara användningen. Jag jobbar som konsult åt ett företag. Företaget (ja eller jag) har av en kund fått i uppdrag att revidera dessa 112 filer + 14x3 CAD-filer då de inför ett nytt system. Det handlar om ca 80 textsträngar som ska ersättas och inte samma 80 i alla filer. Plus en hel del annan handpåläggning. Eftersom jag är, som en del av er vet, extremt lat ville jag förenkla detta med den här mjukvaran, som jag införskaffade på eget bevåg, och den här hjälpen jag får här. Vinningen är att jag slipper få ett psykbryt på att göra detta "för hand". Företaget jag jobbar åt går miste om timersättning då jag kanske löser detta snabbare (fast det har tagit en jäkla tid hittills) och kunden kommer då billigare undan. Det är alltså ingen som tjänar pengar på att jag har fått den här hjälpen. Tvärtom.

 

Megastort tack!

 

Redigerad Augusti 16, 2023 av Mikael63
hmm