Macro excel data importeren in excel tabblad

[Robert971]

Hallo,

Iemand een idee hoe je d.m.v. een macro (bv dmv een button) Excel data kan inlezen vanuit een ander Excel bestand. Twee varianten:
1. Data uit een xls bestand (opgeslagen in een willekeurige bestandsmap) inlezen in geopend Excel bestand.
2. Data inlezen vanuit een ander geopend Excel bestand in huidig geopend Excel bestand.
Voor wat betreft variant 1 deze staat niet op een vaste locatie, maar de bedoeling is dat de gebruiker zelf gedurende het draaien van de macro het betreffende Excel bestand selecteert (vanuit een willekeurige locatie) waarna het automatisch ingelezen wordt in het al geopende Excel bestand. Daarbij zou het mooi zijn als de ingelezen Excel data beveiligd ingelezen kan worden zodat deze niet meer kan worden veranderd door de gebruiker (voor beide varianten overigens). Wel moet mogelijk zijn de data nog te gebruiken voor formules/verwijzingen/macro's.

Ik hoop dat iemand me verder kan helpen.

Alvast dank.

Robert

 

[leofact]

De volgende routine opent het File dialoog venster waarin je een bron bestand kan selecteren.
Het bronbestand wordt geopend, gekopieerd en vervolgens weer gesloten.
De code kopieert steeds de waardes van een range uit de eerste drie werkbladen, maar dat is natuurlijk aan de eigen behoefte aan te passeren.

Mvg Leo

Sub InhoudKopieren()

Dim sh1b As Object
Dim sh1a As Object
Dim sh2a As Object
Dim sh2b As Object
Dim sh3a As Object
Dim sh3b As Object
Dim oBoek1 As Object
Dim oBoek2 As Object
Dim objBs As Variant
Dim fDialoog As FileDialog
Dim sBestandsnaam As String
Dim sNaam As String
Dim sPad As String

'Stel het werkboek en het pad in.
Set oBoek1 = ThisWorkbook
sPad = oBoek1.Path
'Pas het fiiledialoog aan en open het
Set fDialoog = Application.FileDialog(msoFileDialogOpen)
    With fDialoog
        .Title = "Selecteer het te kopiëren Werboek"
        .ButtonName = "Kopieer bord"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "1. Excel 2010", "*.xlsm"
        .Filters.Add "2. Excel 2003", "*.xls"
        .InitialView = msoFileDialogViewDetails
        .InitialFileName = sPad
        .Show
        'Haal bestandsnaam op.
            For Each objBs In .SelectedItems
                sBestandsnaam = objBs
        Next objBs
    End With
    'Juist bestand geslecteerd?
        If sBestandsnaam = "" Then
                MsgBox "Er is geen bestand geselecteerd"
            GoTo ResetAlles
        End If
    sNaam = Strings.Mid(sBestandsnaam, InStrRev(sBestandsnaam, "\") + 1)
    If sBestandsnaam = oBoek1.Name Then
        MsgBox "Wijzig eerst de naam van het bestand" & vbLf & _
           "Start dan de kopieer routine opnieuw."
        GoTo ResetAlles
    End If
If Strings.InStr(1, Strings.UCase(sBestandsnaam), "xls", 1) = 0 Then
    MsgBox "Onbekend bestand: " & sNaam & vbLf & vbLf _
        & "Het geselecteerde bestand wordt niet herkend als Excel Werkboek" & vbLf _
        & "Start de kopieer routine opnieuw en selecteer het juiste bestand." & vbLf _
           
           GoTo ResetAlles
    End If
On Error GoTo Fout
'klaarmaken voor kopiëeren
With Application
    .EnableEvents = False
    .ScreenUpdating = False
    .DisplayAlerts = False
    End With
'open het werkboek
Workbooks.Open sBestandsnaam
'kopieer
Set oBoek2 = ActiveWorkbook
Set sh1a = oBoek1.Worksheets(1)
Set sh1b = oBoek2.Worksheets(1)
Set sh2a = oBoek1.Worksheets(2)
Set sh2b = oBoek2.Worksheets(3)
Set sh3a = oBoek1.Worksheets(3)
Set sh3b = oBoek2.Worksheets(3)
    sh1b.Range("a5", "aC600").Copy
            sh1a.Range("a5").PasteSpecial Paste:=xlPasteValues
    sh1b.Range("af2", "af100").Copy
        sh1a.Range("af2").PasteSpecial Paste:=xlPasteValues
    sh2b.Range("a4", "ad100").Copy
        sh2a.Range("a4").PasteSpecial Paste:=xlPasteValues
    sh3b.Range("A4", "g50").Copy
        sh3a.Range("a4").PasteSpecial Paste:=xlPasteValues
'Sluit het bronbestand en ga naar het eerste blad
oBoek2.Close
    sh1a.Activate
        sh1a.Cells(5, 2).Select
'Zet alles weer op 0
ResetAlles:
With Application
        .EnableEvents = True
        .DisplayAlerts = True
End With
Set sh1a = Nothing
Set sh1b = Nothing
Set sh2a = Nothing
Set sh2b = Nothing
Set sh3a = Nothing
Set sh3b = Nothing
Set oBoek1 = Nothing
Set oBoek2 = Nothing
Set fDialoog = Nothing
On Error GoTo 0
Exit Sub
' foutafhandeling ------------------------------------
Fout:
    MsgBox "Kopieerfout:" & vbLf _
        & "Het geselcteerde bestand wordt" & vbLf _
            & "niet herkend als factbord." & vbLf _
        & "Start de kopieer routine opnieuw" & vbLf _
    & "en selecteer het juiste bestand."
Unload UfWacht
Application.EnableEvents = True
  Application.DisplayAlerts = True
End Sub

 

[Robert971]

Bedankt Leo!

Hiermee ben ik erg geholpen.

Groet,
Robert

 

[leofact]

Mooi, graag gedaan.
Mvg Leo

 

[Cedexis]

Beste Leo,

Kan ik hier nog een aanvullende vraag op stellen?
Want ik zou op basis van het bovenstaande een kleine wijziging hebben.
Ik heb de hele dag zelf zitten puzzelen maar misschien kun je me sneller helpen?

Ik heb 1 map waar elke dag ca 15 Excel lijsten worden geupload.
De mapnaam wijzigt ook elke dag.
De lijsten zijn allemaal qua opzet hetzelfde, en dezelfde cellen zijn ingevuld.
Ik zou graag willen dat de informatie in dezelfde cellen op 1 tabblad wordt gecopieerd.
De VBA zal dus nadat hij ca. 7 cellen heeft gecopieerd, naar de volgende regel moeten gaan.
Net zolang als dat er bestanden zijn.

Hopelijk is de vraagstelling zo duidelijk? Het is in mijn hoofd heel duidelijk iig

Groet Luuk