Just nu i M3-nätverket
Gå till innehåll

VBA för att hämta celler ur flera exceldokument


jimmyene
 Share

Rekommendera Poster

Hej,

Jag försöker få ett VBA att funka som ska hämta info ur ett antal givna celler ur ett stort antal dokument, jag har hittat (här på foorumet) och försökt modifiera nedan kod så den ska funka men jag får det inte aatt funka.

 

Jag har skapat dokumentet test.xlsm och klistrat in koden under vba projects for test.xlsm i filen blad1. Vad gör jag för fel, när jag kör denna fylls inte filen på med några värden det tuggar en stund men kalkylbladet är fortfarande tomt. Stort tack på förhand!

 

Här kommer koden;


Option Explicit

Sub test()

Dim Summa As Variant

Dim i As Integer
Dim Namn As String
Dim Telefon As String
Dim email As String
Dim regnr As String
Dim strBook As String, strDir As String, strSpec As String
Dim objBook As Object

Application.EnableEvents = False                    'Stänger av händelsehantering
Application.ScreenUpdating = False                  'Stänger av skärmuppdatering
Application.Calculation = xlCalculationManual       'Stänger automatisk kalkylering

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Förvaringskunder"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Canceled"
        Else
            strDir = .SelectedItems(1)
            strSpec = "*.xlsx"                           'Kan behöva ändras till filändelse *.xlsx
            strBook = Dir(.SelectedItems(1) & "\" & strSpec)
        End If
End With

i = 1

Do Until strBook = ""
   
    i = i + 1
    Set objBook = Workbooks.Open(strDir & "\" & strBook)
    Sheets("Blad1").Select
    Namn = Range("b6").Value
    Telefon = Range("F6").Value
    email = Range("F10").Value
    regnr = Range("B3").Value
    
    Windows("test.xlsm").Activate               'Kan behöva ändras till annan filändelse.
    
    Range(Cells(i, 1), Cells(i, 1)).Value = Namn
    Range(Cells(i, 2), Cells(i, 2)).Value = Telefon
    Range(Cells(i, 3), Cells(i, 3)).Value = email
    Range(Cells(i, 4), Cells(i, 4)).Value = regnr
    
    objBook.Close savechanges:=True
    
    strBook = Dir()
Loop

Application.EnableEvents = True                     ppnar av händelsehantering
Application.ScreenUpdating = True                   ppnar av skärmuppdatering
Application.Calculation = xlCalculationAutomatic    ppnar automatisk kalkylering

End Sub


 

Länk till kommentar
Dela på andra webbplatser

Frågan man kan ställa sig ovan är vilket blad skrivs raden

Range(Cells(i, 1), Cells(i, 1)).Value = Namn
    

till?

ge full adress till arbetsbok och blad och som det kanske hjälper.

Dvs

With Workbooks("test.xlsm").Worksheets("Blad1")
   .Range(...) = ....
    Debug.Print "Lade till värden"
End with

Men kolla även om du verkligen loopar igenom något i din loop. Sätt en brytpunkt eller lägg till debug-meddelande som ovan så ser du i Direktfönstret vad som sker.

 

Länk till kommentar
Dela på andra webbplatser

Tack det verkar ha hjälpt mig en del men nu har jag fastnat på ett felmeddelande.

Körfel nr 9 indexet är utanför intervall. bifogar länken till där man hamnar om man trycker på hjälp;

 

https://docs.microsoft.com/sv-se/office/vba/Language/Reference/User-Interface-Help/subscript-out-of-range-error-9

 

Nåt vidare tips på vad som kan vara felet?

 

Bifogar koden som den ser ut nu;

 


Option Explicit

Sub test()

Dim Summa As Variant

Dim i As Integer
Dim Namn As String
Dim Telefon As String
Dim Email As String
Dim Regnr As String
Dim strBook As String, strDir As String, strSpec As String
Dim objBook As Object

Application.EnableEvents = False                    'Stänger av händelsehantering
Application.ScreenUpdating = False                  'Stänger av skärmuppdatering
Application.Calculation = xlCalculationManual       'Stänger automatisk kalkylering

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Förvaringskunder"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Canceled"
        Else
            strDir = .SelectedItems(1)
            strSpec = "*.xlsx"                           'Kan behöva ändras till filändelse *.xlsx
            strBook = Dir(.SelectedItems(1) & "\" & strSpec)
        End If
End With

i = 1

Do Until strBook = ""
   
    i = i + 1
    Set objBook = Workbooks.Open(strDir & "\" & strBook)
    Sheets("Blad1").Select
    Namn = Range("b6").Value
    Telefon = Range("F6").Value
    Email = Range("F10").Value
    Regnr = Range("B3").Value
    
    Windows("test.xlsm").Activate               'Kan behöva ändras till annan filändelse.
    
With Workbooks("C:\Users\info\Desktop\test.xlsm").Worksheets("Blad1")
    Range(Cells(i, 1), Cells(i, 1)).Value = Namn
    Range(Cells(i, 2), Cells(i, 2)).Value = Telefon
    Range(Cells(i, 3), Cells(i, 3)).Value = Email
    Range(Cells(i, 4), Cells(i, 4)).Value = Regnr
    Debug.Print "Lade till värden"
End With
    
    
    objBook.Close savechanges:=True
    
    strBook = Dir()
Loop

Application.EnableEvents = True                     'Öppnar av händelsehantering
Application.ScreenUpdating = True                   'Öppnar av skärmuppdatering
Application.Calculation = xlCalculationAutomatic    'Öppnar automatisk kalkylering

End Sub


 

 

Mvh Jimmy

Länk till kommentar
Dela på andra webbplatser

With Workbooks("test.xlsm").Worksheets("Blad1")
    .Range(Cells(i, 1), Cells(i, 1)).Value = Namn
    .Range(Cells(i, 2), Cells(i, 2)).Value = Telefon
    .Range(Cells(i, 3), Cells(i, 3)).Value = Email
    .Range(Cells(i, 4), Cells(i, 4)).Value = Regnr
    Debug.Print "Lade till värden"
End With

Borde fungera bättre.

 

Samt

 With Sheets("Blad1")
    Namn = .Range("b6").Value
    Telefon = .Range("F6").Value
    Email = .Range("F10").Value
    Regnr = .Range("B3").Value
End With

 

När får fel som du får brukar bästa vara att stega genom koden och se vilken rad som slänger det.

 

Länk till kommentar
Dela på andra webbplatser

46 minuter sedan, skrev DanneK:

Jag vart lite nyfiken på hur den slutliga koden för detta såg ut.

Här kommer den;

 


Option Explicit

Sub test()

Dim Summa As Variant

Dim i As Integer
Dim Namn As String
Dim Telefon As String
Dim Email As String
Dim Regnr As String
Dim strBook As String, strDir As String, strSpec As String
Dim objBook As Object

Application.EnableEvents = False                    'Stänger av händelsehantering
Application.ScreenUpdating = False                  'Stänger av skärmuppdatering
Application.Calculation = xlCalculationManual       'Stänger automatisk kalkylering

With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Förvaringskunder"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Canceled"
        Else
            strDir = .SelectedItems(1)
            strSpec = "*.xlsx"                           'Kan behöva ändras till filändelse *.xlsx
            strBook = Dir(.SelectedItems(1) & "\" & strSpec)
        End If
End With

i = 1

Do Until strBook = ""
   
    i = i + 1
    Set objBook = Workbooks.Open(strDir & "\" & strBook)
    Sheets("Blad1").Select
With Sheets("Blad1")
    Namn = .Range("B6").Value
    Telefon = .Range("F6").Value
    Email = .Range("F10").Value
    Regnr = .Range("B3").Value
End With
    
    Windows("test.xlsm").Activate               'Kan behöva ändras till annan filändelse.C:\Users\info\Desktop\test.xlsm
    
With Workbooks("test.xlsm").Worksheets("Blad1")
    .Range(Cells(i, 1), Cells(i, 1)).Value = Namn
    .Range(Cells(i, 2), Cells(i, 2)).Value = Telefon
    .Range(Cells(i, 3), Cells(i, 3)).Value = Email
    .Range(Cells(i, 4), Cells(i, 4)).Value = Regnr
    Debug.Print "Lade till värden"
End With
    
    
    objBook.Close savechanges:=True
    
    strBook = Dir()
Loop

Application.EnableEvents = True                     'Öppnar av händelsehantering
Application.ScreenUpdating = True                   'Öppnar av skärmuppdatering
Application.Calculation = xlCalculationAutomatic    'Öppnar automatisk kalkylering

End Sub


 

  • Tack 1
Länk till kommentar
Dela på andra webbplatser

6 timmar sedan, skrev jimmyene:

Windows("test.xlsm").Activate

Ta bara bort den raden så blir det finare.  Behövs inte och man ska alltid undvika select- och activate-satser.

 

Länk till kommentar
Dela på andra webbplatser

 Share

×
×
  • Skapa nytt...