Excel 2007 VBA importere flere text å xls filer på en gang ut i fra cellereferanser

[Bigelk]

Hei.

 

jeg skal importere flere filer, de filene som skal importeres skal velges ut i fra en kalender.

hvis jeg f.eks velger Januar, skal alle filene for januar velges, hvis jeg velger uke1 skal

de filene som gjelder for uke1 importeres å hvis jeg velger 1 av dagene skal de filene som gjelder for denne dagen importeres.

 

Selve teksten Januar har range B1

mens navnene på filene som "tilhører" januar har range B3 til H7

 

Uke1 står i A3

mens navnene på filene som tilhører uke1 har range B3 til H3

 

Jeg har en kode i dag som jeg bruker for importere en dag om gangen.

Men jeg vet ikke om den kan modifiseres for multiplefile importering

Application.ScreenUpdating = False

   Dim FPath As Variant
   Dim X As range

   FPath = "\\filserver\tope\test\"
   Set X = range("b2:h7")

   If Intersect(X, ActiveCell) Is Nothing Then
       Exit Sub
   Else
       With Sheets("ark2").QueryTables.Add(Connection:= _
           "TEXT;" & FPath & ActiveCell & ".txt", _
           Destination:=Sheets("ark2").range("A1"))
           .RefreshStyle = xlInsertDeleteCells
           .Refresh BackgroundQuery:=False
       End With

       Sheets("ark2").Select
       Columns("a:a").Select
       Selection.TextToColumns Destination:=range("A1"), DataType:=xlFixedWidth, _
       FieldInfo:=Array(Array(0, 1), Array(4, 1), Array(44, 1), Array(45, 1), Array(55, 1), _
       Array(58, 1), Array(70, 1), Array(77, 1)), TrailingMinusNumbers:=True
       Sheets("ark1").Select
   End If


   If Intersect(X, ActiveCell) Is Nothing Then
       Exit Sub
   Else
       With Sheets("ark3").QueryTables.Add(Connection:= _
           "TEXT;" & FPath & ActiveCell & ".xls", _
           Destination:=Sheets("ark3").range("A1"))
           .RefreshStyle = xlInsertDeleteCells
           .Refresh BackgroundQuery:=False
       End With

       Sheets("ark3").Select
       Columns("B:B").Select
       Selection.ClearContents
       Columns("A:A").Select
       Selection.TextToColumns Destination:=range("A1"), DataType:=xlFixedWidth, _
       FieldInfo:=Array(Array(0, 1), Array(7, 1)), TrailingMinusNumbers:=True
       Sheets("ark1").Select
   End If

   Application.ScreenUpdating = True

 

Noen forslag på hvordan jeg skal gå fram?

 

Hilsen

 

Torbjørn

Endret 13. februar 2012 av Bigelk