vba kode til at scanne mappe for filnavne

Et alternativ kunne være at gemme filerne med dato + klokkeslet - dog skal kolon i dette fjernes (: må ikke anvendes i filnavn).

Hvis du skal have skrevet koden om, så kunne du jo vise, hvordan den bestående ser ud.

Public Sub NytArk()
    Dim Navn As String
    Worksheets.Add
    Navn = Date
    i = 1
    If Not EksistererArk(Navn) Then
        ActiveSheet.Name = Navn
    Else
        Do
            i = i + 1
            Navn = Date & "_" & i
        Loop Until Not EksistererArk(Navn)
        ActiveSheet.Name = Navn
    End If
End Sub

Public Function EksistererArk(nyNavn) As Boolean
    For Each ark In Worksheets
        If ark.Name = nyNavn Then
            EksistererArk = True
        End If
    Next
End Function

lige en tilføjelse, så den er hurtigere

Public Function EksistererArk(nyNavn) As Boolean
EksistererArk = False
    For Each ark In Worksheets
        If ark.Name = nyNavn Then
            EksistererArk = True
            exit function
        End If
    Next
End Function

jeg har vidst ik forklaret mig helt tydeligt.

det er ik på arkbasis men på filbasis.
Det vil sige at hvert ark ligger i en seperat fil, og det er filen der har "dato navnet" så det er mappen man skan scanne igennem og læse filnavne på de filerne der ligger der for at se om der er nogle med samme navn og hvis der er så skal filen slutte og 2,3,4 osv.

Sub FNavn()

sti = "c:\Users\pm\Desktop\" ' Ret stinavn til aktuel
nr = 1
First = True
Do While (1)
   
If First = True Then
FilNavn = Dir(sti + "\*.xls")
First = False
Else
FilNavn = Dir
End If
     
If FilNavn = "" Then Exit Do
     
If Left(FilNavn, 10) Like Date Then
nr = nr + 1
End If

Loop

ThisWorkbook.SaveCopyAs sti & Date & "_" & nr & ".xls"

End Sub

tak for koden, men nu har jeg ik prøvet koden endnu, men umiddelbart ser jeg lidt problemer.

Da excelfilen hvor man trykker på knappen ligger på et netværksdrev og der er mange brugere på netværket der bruger den, også samtidig. og brugerne åbner filen trykker på knappen og lukker excel ned igen og åbner det måske sidst på dagen og trykke på knappen igen. er der taget højde for det i koden?

det er samme mappe på netværksdrevet som kopi af excelarkene/filerne bliver gemt i, bare til info.

umiddelbart tror jeg ikke det skaber problemer - men er ikke 100%
Når koden køres, skannes mappen for filer der starter med dags dato
variablen nr tæller antal som matcher og tilføjes filnavn

sådan ser den originale kode ud, hjælper det?

det skal lige siges at Hensættelser.TextBox169.Text indeholder dagsdato fra en anden funktion.


Public Sub GemKopiAfBilag()

On Error GoTo fejl
Dim elektroniskBilagsfil As String

    elektroniskBilagsfil = Hensættelser.TextBox169.Text

    Call OpretBilagIExcel


    Sheets("bilag").Select
    Sheets("bilag").Copy
    ActiveWorkbook.SaveAs Filename:= _
        "Q:\1_NPA_enheder\RR\Bilagshistorik\" + elektroniskBilagsfil + ".xls", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    ActiveWindow.Close
    Sheets("Programstart").Select

Exit Sub



fejl:
MsgBox "Fejl, ændre eventuelt filnavn,"

End Sub

Public Sub GemKopiAfBilag()

  ' On Error GoTo fejl
    Dim elektroniskBilagsfil As String

    elektroniskBilagsfil = Hensættelser.TextBox169.Text
 
      Call OpretBilagIExcel


    Sheets("bilag").Select
    Sheets("bilag").Copy
   
    Do Until Dir("Q:\1_NPA_enheder\RR\Bilagshistorik\" + elektroniskBilagsfil + ".xls") = ""
        x = x + 1
        elektroniskBilagsfil = Hensættelser.TextBox169.Text & "_" & x
    Loop
   
    ActiveWorkbook.SaveAs Filename:= _
                          "Q:\1_NPA_enheder\RR\Bilagshistorik\" + elektroniskBilagsfil + ".xls", FileFormat:=xlNormal, _
                          Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
                          CreateBackup:=False
    ActiveWindow.Close
    Sheets("Programstart").Select
   
MsgBox "gemt som, " + elektroniskBilagsfil + ".xls"

    Exit Sub


End Sub

den virker sku kabbak, skide fedt. tak. svar så der point

et svar ;-))