Har brug for en funktion..

Jeg er nået så langt jeg lægger alle mine fil navne ind i et array.

Jeg kan også tage en substring af filnavnet og bruge denne til at sammenligne med en "betingelse". Men Jeg ved ikke hvordan jeg ændrer det til at være en substring af et andet fil navn således.

if substring_fil_navn_1 = substring_fil_navn_2 then
do something

min kode er:


    'Fill in the path\folder where the files are
    MyPath = ThisWorkbook.path & "\data\salgsdata\"
       
        'If there are no Excel files in the folder exit the sub
    FilesInPath = Dir(MyPath & "*.xls*")
    If FilesInPath = "" Then
        MsgBox "No files found"
        Exit Sub
    End If

    'Fill the array(myFiles)with the list of Excel files in the folder
    Fnum = 0
    Do While FilesInPath <> ""
        Fnum = Fnum + 1
        ReDim Preserve MyFiles(1 To Fnum)
        MyFiles(Fnum) = FilesInPath
        FilesInPath = Dir()
    Loop

For i = LBound(MyFiles) To UBound(MyFiles)

If Mid(MyFiles(i), 11, 4) = "2007" Then

MsgBox ("år lol")

End If


Next i


End Sub

Prøv denne - obs dubletterne indsættes forløbig i kolonne A og B i aktive Ark
Skal der laves noget i de åbnede projektmapper, skal det gøres via koden, med mindre du blot vil have alle åbnet for editering

Sub DubXLS()
Dim Projektmapper1(100)
Dim Projektmapper2(100)

sti1 = "C:\Users\pm\Desktop\*.xls" ' ret sti til aktuel
fil1 = Dir(sti1)
Do While fil1 <> ""
  Projektmapper1(tal1) = fil1
  tal1 = tal1 + 1
  fil1 = Dir
Loop

sti2 = "C:\Users\pm\Desktop\Experten\*.xls" ' ret sti til aktuel
fil2 = Dir(sti2)
Do While fil2 <> ""
  Projektmapper2(tal2) = fil2
  tal2 = tal2 + 1
  fil2 = Dir
Loop

For x = 0 To tal1 - 1
For y = 0 To tal2 - 1
If Right(Projektmapper1(x), 8) = Right(Projektmapper2(y), 8) Then 'ret til 9 hvis Excel7
rk = rk + 1
Cells(rk, 1) = Projektmapper1(x)
Cells(rk, 2) = Projektmapper2(y)
End If
Next
Next

End Sub

Grund ideen er, at jeg vil åbne 2 som "matcher" 4 karaktere i filnavnet.

Åbne dem, "editere dem via VBA kode". Lukke dem, køre videre og finde 2 nye som "matcher, åbne dem, editere, lukke igen, osv.

indtil jeg har taget alle filer "som matcher" og editeret efter mit "behov".

- håber det var forståeligt.

HAr tilpasset din kode lidt og det kører super godt.

Men har lidt problemer med at åbne projektmapperne når de nu er gemt i Array.

prøv:

Sub DubXLS()
Dim Projektmapper1(100)
Dim Projektmapper2(100)

sti1 = "C:\Users\pm\Desktop\K22\*.xls" ' ret sti til aktuel
fil1 = Dir(sti1)
Do While fil1 <> ""
  Projektmapper1(tal1) = fil1
  tal1 = tal1 + 1
  fil1 = Dir
Loop

sti2 = "C:\Users\pm\Desktop\Experten\*.xls" ' ret sti til aktuel
fil2 = Dir(sti2)
Do While fil2 <> ""
  Projektmapper2(tal2) = fil2
  tal2 = tal2 + 1
  fil2 = Dir
Loop

For x = 0 To tal1 - 1
For y = 0 To tal2 - 1
If Right(Projektmapper1(x), 8) = Right(Projektmapper2(y), 8) Then 'ret til 9 hvis Excel7
rk = rk + 1
Cells(rk, 1) = Projektmapper1(x)
Cells(rk, 2) = Projektmapper2(y)
sti11 = Left(sti1, Len(sti1) - 5)
sti22 = Left(sti2, Len(sti2) - 5)
Workbooks.Open sti11 & Projektmapper1(x)
Workbooks.Open sti22 & Projektmapper2(y)
'
'do ur stuff
'
Workbooks(Projektmapper1(x)).Close SaveChanges:=True
Workbooks(Projektmapper2(y)).Close SaveChanges:=True
End If
Next
Next

End Sub

slet evt skrivning til ark
Cells(rk, 1) = Projektmapper1(x)
Cells(rk, 2) = Projektmapper2(y)

De kører prima!

Smid et svar også får du point..

ok kommer her

Tak for hjælpen..

Kan være jeg vender tilbage, hvis jeg løber ind i flere problemer.