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

jimmyene

Medlem
  • Antal inlägg

    4
  • Gick med

  • Senaste besök

Om jimmyene

  • Medlemstitel
    Nykomling

Senaste profilbesöken

Blocket med senaste besökare är inaktiverat och visas inte för andra besökare.

  1. 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
  2. Ett enormt tack, nu funkar den klockrent och jag har sparat enormt med tid. Mvh Jimmy
  3. 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
  4. 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
×
×
  • Skapa nytt...