Än så länge har jag lyckats att leta igeom mappar och skriva ut namnet på mappen i nya xls arken.

Public Function FileFolderExists(strFullPath As String) As Boolean
    On Error GoTo EarlyExit
    If Not Dir(strFullPath, vbDirectory) = vbNullString Then FileFolderExists = True
   
EarlyExit:
    On Error GoTo 0

End Function

Sub List_Sub_Directories()
Dim dirList() As String
List_Directories "F:\", dirList()
Print_List dirList()
 
i = 1
Range("A" & 1).Select
Do While ActiveCell.Value <> ""
       
        'Går igenom nya strukturen.
        Mappnamn = ActiveCell.Offset(0, 0).Value
        If InStr(1, ActiveCell.Offset(0, 0).Value, " - ", vbTextCompare) Then
            If FileFolderExists("C:\" & ActiveCell.Offset(0, 0).Value & "\map-1\map-2\fil.xls") Then
           
               Konto = 2
               HoppaTillbaka = 0
               Do While Range("A" & Konto) <> ""
                ActiveCell.Offset(1, 0).Select
               
                Konto = Konto + 1
                HoppaTillbaka = HoppaTillbaka + 1
               Loop
               ActiveCell.Offset(-HoppaTillbaka, 0).Select
               ActiveCell.Offset(0, 1).Select
            Else
               
                ActiveCell.Offset(0, 0).Select
                Selection.EntireColumn.Select
              
                Selection.Delete Shift:=x1ToLeft
               
            End If
               
        Else
        ' gammal struktur

            If FileFolderExists("C:\" & ActiveCell.Offset(0, 0).Value & "\map1\map2\fil.xls") Then
               Konto = 2
               HoppaTillbaka = 0
               Do While Range("A" & Konto) <> ""
                ActiveCell.Offset(1, 0).Select
            
       
                Konto = Konto + 1
                HoppaTillbaka = HoppaTillbaka + 1
               Loop
               ActiveCell.Offset(-HoppaTillbaka, 0).Select
                ActiveCell.Offset(0, 1).Select
            Else
       
                ActiveCell.Offset(0, 0).Select
                Selection.EntireColumn.Select
       
               Selection.Delete Shift:=x1ToLeft
       
            End If
      
           
        End If

 
     
   
       
    Loop
End Sub
Sub List_Directories(anypath As String, dirList() As String)
Dim dirOutput As String, i%
dirOutput = Dir(anypath, vbDirectory)
Do While dirOutput <> ""
If dirOutput <> "." And dirOutput <> ".." Then
    If (GetAttr(anypath & dirOutput) And vbDirectory) = vbDirectory Then
        i = i + 1
        ReDim Preserve dirList(1 To i)
        dirList(i) = dirOutput
    End If
End If
dirOutput = Dir()
Loop
End Sub
Sub Print_List(anyList() As String)
Dim i%, j%

Range("A" & 1).Select
For i = LBound(anyList) To UBound(anyList)
If LBound(anyList) = 0 Then j = 1

ActiveCell.Value = anyList(i)
ActiveCell.Offset(0, 1).Select
'Cells(i + 2, 1).Value = anyList(i)
Next
End Sub

Jag vill att namnet på mappar som innehåller fil.xls ska skrivas på rad 20 men jag lyckas inte att göra det och vet inte varför. jag har provat med att ändra range på aktivcell men den bara vägrar.

Sedan vill jag hämta information från målfilen från kolumn A, B och I, rad 11 och blad2. I resultat excel filen ska header på kolumn A, B och I och tillhörande lagrade info visas. Sedan ska jag kunna gå igenom alla mappar som just denna xcelfilen finns och hämta info från samma kolumn och presentera i nya filen som heter "resultat".