algemene macro, werkend voor meerdere bestanden

[mieppie1984]

Ik ben op zoek naar een macro die niet gekoppeld is aan een bestand en geen bestandsverwijzing heeft.

Het bronbestand kun je zien als het basisprogramma, om ruimte te besparen willen we niet steeds dit programma in zijn geheel opslaan, enkel de ingevoerde gegevens. Het basisprogramma bevat een bibiotheek aan gegevens welke alleen daar wordt aangepast, zodat je altijd met de nieuwste informatie werkt.

Het zit zo, vanaf het bronbestand kopieren we een aantal kolommen met gegevens en slaan deze als apart bestand op.
Later moeten we deze gegevens weer kunnen bewerken in het programma. en kopieren we deze gegevens weer naar het bronbestand, zodat ze verder bewerkt kunnen worden.

Werkt prima als je het aparte bestand een naam hebt gegeven en deze in de macro genoemd staat.
Maar er zullen 1000 enden van deze bestanden komen. Hoe kan ik de macro werkend maken voor al deze bestanden?
Deze aparte bestanden zullen niet tegelijk geopend worden.
Stel ik open zo'n willekeurig bestand, wat zou de code zijn om de gegevens weer naar het bronbestand te kopieren?

Ik had dus al een macro hiervoor welke werkt op/vanuit het bestand: test 007.xls
Wat moet ik neerzetten ipv de bestandsnaam?

Sub GEgevens_terugzetten_2()
'
' GEgevens_terugzetten_2 Macro
'

'
    Workbooks.Open Filename:= _
        "X:calculatieprogramma nieuw.36test.xls" _
        , UpdateLinks:=0
    Windows("test 007.xls").Activate
    Range("A1:D997").Select
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("B10").Select
    ActiveSheet.Paste
    Windows("test 007.xls").Activate
    Range("E1:E997").Select
    Range("E997").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("J10").Select
    ActiveSheet.Paste
    Windows("test 007.xls").Activate
    Range("F1:I997").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("O10").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollRow = 985
    ActiveWindow.ScrollRow = 955
    ActiveWindow.ScrollRow = 867
    ActiveWindow.ScrollRow = 808
    ActiveWindow.ScrollRow = 778
    ActiveWindow.ScrollRow = 690
    ActiveWindow.ScrollRow = 601
    ActiveWindow.ScrollRow = 542
    ActiveWindow.ScrollRow = 513
    ActiveWindow.ScrollRow = 454
    ActiveWindow.ScrollRow = 336
    ActiveWindow.ScrollRow = 306
    ActiveWindow.ScrollRow = 247
    ActiveWindow.ScrollRow = 188
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 11
    Range("B11").Select
    Windows("test 007.xls").Activate
End Sub

Alvast bedankt voor jullie hulp!

gr. Miranda

 

[r3000]

Miranda,

Kun je een voorbeeld bestand posten?

 

[mieppie1984]

Ik heb hier 2 voorbeeldbestanden.
- De bron (programma)
- voorbeeld 2 (apart bestand dat wordt opgeslagen. gegevens bijv. via macro "Kopie_gegevens" in Bronbestand)

daarna is het de bedoeling dat het "lege" bronbestand wordt gevuld met de gegevens uit voorbeeld 2 via macro "Gegevens_terugzetten".
Maar deze zal in de praktijk vele malen voorkomen, allemaal opgeslagen onder een unieke naam.

Als het kan heb ik nog een wens:
De gegevens in het blauwe blok bovenin, ook opslaan in hetzelfde aparte bestand en weer terug kunnen invoegen.
Dit lukt me niet op dezelfde manier, hij geeft dan aan dat het buiten het bereik valt??

Ik hoop dat jullie hier wat aan hebben.
Hebben jullie compleet andere ideeën? Ze zijn welkom!

gr. Miranda

 

[Elsendoorn2134]

Mieppie,

Het is het handigste als je gewoon een scherm krijgt waar je een bestand kan kiezen.
Probeer de volgende kode eens.

Sub GEgevens_terugzetten_2()
'
' GEgevens_terugzetten_2 Macro
'

'
    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant
    Dim sBestandsnaam As String

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Use a With...End With block to reference the FileDialog object.
    With fd
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                sBestandsnaam = vrtSelectedItem
            Next vrtSelectedItem
        'The user pressed Cancel.
        Else
        End If
    End With

    'Set the object variable to Nothing.
    Set fd = Nothing


    Workbooks.Open Filename:= _
        "X:calculatieprogramma nieuw.36test.xls" _
        , UpdateLinks:=0
    Windows(sBestandsnaam).Activate
    Range("A1:D997").Select
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("B10").Select
    ActiveSheet.Paste
    Windows(sBestandsnaam).Activate
    Range("E1:E997").Select
    Range("E997").Activate
    Application.CutCopyMode = False
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("J10").Select
    ActiveSheet.Paste
    Windows(sBestandsnaam).Activate
    Range("F1:I997").Select
    Application.CutCopyMode = False
    Selection.Copy
    Windows("calculatieprogramma nieuw.36test.xls").Activate
    Range("O10").Select
    ActiveSheet.Paste
    ActiveWindow.ScrollRow = 985
    ActiveWindow.ScrollRow = 955
    ActiveWindow.ScrollRow = 867
    ActiveWindow.ScrollRow = 808
    ActiveWindow.ScrollRow = 778
    ActiveWindow.ScrollRow = 690
    ActiveWindow.ScrollRow = 601
    ActiveWindow.ScrollRow = 542
    ActiveWindow.ScrollRow = 513
    ActiveWindow.ScrollRow = 454
    ActiveWindow.ScrollRow = 336
    ActiveWindow.ScrollRow = 306
    ActiveWindow.ScrollRow = 247
    ActiveWindow.ScrollRow = 188
    ActiveWindow.ScrollRow = 70
    ActiveWindow.ScrollRow = 11
    Range("B11").Select
    Windows(sBestandsnaam).Activate
End Sub

Veel Succes.

 

[snb]

Maak gebruik van Excels ingebouwde mogelijkheden.
Zet in cel A10 van blad 1 van bron.xls een databasequery naar blad 1 van bestand voorbeeld 2.xls.

Daar is helemaal geen VBA voor nodig.

Suggesties:
- Laat Excel een nieuw bestand altijd aanmaken met slechts 1 werkblad.
- Vermijd 'Select' en 'Activate' in VBA

 

[mieppie1984]

Bedankt voor de code. Zeer enthousiast aan de slag gegaan, maar ik krijg hem echter niet werkend. vanuit welk bestand moet ik hem openen? op beide manieren werkt het niet.

Ik begrijp denk ik wel wat de bedoeling ervan is. ik denk echter dat hij andersom moet zijn.
Dus dat ik in het bronbestand sta en daar een bestand als voorbeeld 2 (Dit heeft altijd een andere naam, per project) in kan openen en invoegen volgens die macro.
Ik ben al even bezig geweest, maar het lukt me niet.

 

[mieppie1984]

Is er nog iemand die mij hiermee kan helpen?
mijn dank is groot!

 

[mieppie1984]

Nogmaals een poging, begin mijn hoop zo langzamerhand te verliezen...

als ik het bronbestand open heb, wil ik een willekeurig bestand kunnen openen (zoals voorbeeld 2) en daarvan de gegevens per kolom, weer in de goede kolom invoegen in het bronbestand.
De macro voor het openen van een willekeurig bestand lukt nog wel, maar de rest wordt steeds gekoppeld aan het bestand "voorbeeld 2" en dat wil ik juist niet!

Zelf vind ik het makkelijker werken om de codes uit te splitsen in diverse macros en die dan weer samen te voegen in 1 macro.
Dus een macro voor "open willekeurig bestand", "kopieer gegevens", "kopieer gegevens2", "plak gegevens" etc.
Voor mij een stuk overzichtelijker en te begrijpen waar een code voor staat.
Tevens ook makkelijker om een deel van de code aan te passen.

In het originele bestand zijn er dan ook vele kolommen/gegevens die terug geplaatst moeten worden.
Dat zal ik dan in jullie code nog moeten zien aan te passen.

Wie o wie kan mij hiermee helpen??????

 

[mieppie1984]

Nog even een aanvulling:

Bovenstaande laatste code werkt deels.

Hij opent inderdaad een venster waar ik een bestand mag kiezen!:thumb:
Als ik deze gekozen heb, lijkt het alsof hij wat doet....
Echter de gegevens worden niet in het bronbestand gezet.
het andere bestand is ook niet geopend als de macro klaar is, geen idee of dat nodig is.

Dus eigenlijk het stukje kopiëren en plakken werkt nog niet naar behoren.

Ik zou het echt zeer op prijs stellen als iemand van jullie mij hiermee kan helpen!

 

[Elsendoorn2134]

Mieppie,

Hierbij een aangepast bronbestand.
Ik zou zelf de macro in het bronbestand zetten, dat is het makkelijkst te onderhouden omdat ik er van uit ga
dat je meerder "voorbeelden 2" hebt. Mocht je meerder bron bestanden en meerder voorbeeld bestanden gebruiken
zou je er over kunnen denken om een apart bestand te maken met de macro's.

Ik heb binnen de macro in de regels verklaringen gezet voor de acties die per regel worden uitgevoerd.
Je wilde in de kop ook nog wat gegevens ingevoerd hebben, ik hier alleen de datum van de verwerking kunnen zetten.

Hierbij de code die in het bestand staat.

Sub Gegevens_terugzetten()
'
' Gegevens_terugzetten Macro
' Aangepast door F.H. Elsendoorn
'
    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant
    Dim sBestandsnaam As String
    Dim sBronbestand As String
    
    sBronbestand = ActiveWorkbook.Name

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Use a With...End With block to reference the FileDialog object.
    With fd
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                sBestandsnaam = vrtSelectedItem
            Next vrtSelectedItem
        'The user pressed Cancel.
        Else
        End If
    End With

    'Set the object variable to Nothing.
    Set fd = Nothing

    'Open gekozen bestand.
    Workbooks.Open Filename:=sBestandsnaam
    'Selecteer eerste twee kolommen.
    Sheets("Blad1").Range("A2:B997").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Blad1").Range("A10").PasteSpecial Paste:=xlPasteAll
    'Selecteer laatste kolom.
    Sheets("Blad1").Range("C2:C997").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Blad1").Range("D10").PasteSpecial Paste:=xlPasteAll
    'Zet de copy mode uit.
    Application.CutCopyMode = False
    
    'Sluit geselecteerd bestand.
    Workbooks(Right(sBestandsnaam, Len(sBestandsnaam) - InStrRev(sBestandsnaam, "\"))).Close SaveChanges:=False
    'Opruimen dialoog object
    Set fd = Nothing
    
    'invullen datum van vandaag.
    Sheets("Blad1").Range("B6").Value = Format(Date, "dd-mm-yyyy")
    
End Sub

Bekijk bijlage Bron.xls

Veel Succes.

 

[mieppie1984]

Beste Elsendoorn,

Bedankt voor de code! Hij werkt:thumb:
Fijn dat je tussen de regels door uitleg hebt gegeven. hier heb ik veel aan gehad!
De code werkt nu.
Echter met heel veel regels.
Is dit misschien nog in te korten? zodat het scherm minder flitst?

groetjes,
Miranda

Sub IMPORT_gegevens()
'
' Import_gegevens Macro

'
    Dim fd As FileDialog
    Dim vrtSelectedItem As Variant
    Dim sBestandsnaam As String
    Dim sBronbestand As String
    
    sBronbestand = ActiveWorkbook.Name

    'Create a FileDialog object as a File Picker dialog box.
    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    'Use a With...End With block to reference the FileDialog object.
    With fd
        If .Show = -1 Then
            'Step through each string in the FileDialogSelectedItems collection.
            For Each vrtSelectedItem In .SelectedItems
                sBestandsnaam = vrtSelectedItem
            Next vrtSelectedItem
        'The user pressed Cancel.
        Else
        End If
    End With

    'Set the object variable to Nothing.
    Set fd = Nothing

'Open gekozen bestand.
    Workbooks.Open Filename:=sBestandsnaam
    'Selecteer Koptekst.
    Sheets("Blad1").Range("A13:A1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("D12").PasteSpecial Paste:=xlPasteAll
    'Selecteer Categorie.
    Sheets("Blad1").Range("B13:B1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("F12").PasteSpecial Paste:=xlPasteAll
     'Selecteer F=.
    Sheets("Blad1").Range("C13:C1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("H12").PasteSpecial Paste:=xlPasteAll
    'Selecteer Product.
    Sheets("Blad1").Range("D13:D1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("J12").PasteSpecial Paste:=xlPasteAll
    'Selecteer Constructietype.
    Sheets("Blad1").Range("F13:F1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("W12").PasteSpecial Paste:=xlPasteAll
    'Selecteer TK.
    Sheets("Blad1").Range("G13:G1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AC12").PasteSpecial Paste:=xlPasteAll
    'Selecteer profiel.
    Sheets("Blad1").Range("H13:H1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AG12").PasteSpecial Paste:=xlPasteAll
    'Selecteer Aantal.
    Sheets("Blad1").Range("I13:I1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AI12").PasteSpecial Paste:=xlPasteAll
    'Selecteer lengte.
    Sheets("Blad1").Range("J13:J1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AK12").PasteSpecial Paste:=xlPasteAll
    'Selecteer bekledingswijze.
    Sheets("Blad1").Range("K13:K1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AN12").PasteSpecial Paste:=xlPasteAll
    'Selecteer F/A.
    Sheets("Blad1").Range("L13:L1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("AP12").PasteSpecial Paste:=xlPasteAll
    'Selecteer dikte.
    Sheets("Blad1").Range("M13:M1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("BA12").PasteSpecial Paste:=xlPasteAll
    'Selecteer M2 laag 1.
    Sheets("Blad1").Range("N13:N1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("CG12").PasteSpecial Paste:=xlPasteAll
    'Selecteer M2 laag 2.
    Sheets("Blad1").Range("O13:O1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DD12").PasteSpecial Paste:=xlPasteAll
    'Selecteer verlies.
    Sheets("Blad1").Range("Q12:Q1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DK11").PasteSpecial Paste:=xlPasteAll
    'Selecteer griplat.
    Sheets("Blad1").Range("R13:R1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DN12").PasteSpecial Paste:=xlPasteAll
    'Selecteer wol laag 1.
    Sheets("Blad1").Range("S13:S1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DQ12").PasteSpecial Paste:=xlPasteAll
    'Selecteer wol laag 2.
    Sheets("Blad1").Range("T13:T1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DT12").PasteSpecial Paste:=xlPasteAll
    'Selecteer Regelwerk.
    Sheets("Blad1").Range("U13:U1008").Copy
    'Plak de gegevens.
    Workbooks(sBronbestand).Sheets("Invoer calculatie").Range("DW12").PasteSpecial Paste:=xlPasteAll
    'Zet de copy mode uit.
    Application.CutCopyMode = False
  'Sluit geselecteerd bestand.
    Workbooks(Right(sBestandsnaam, Len(sBestandsnaam) - InStrRev(sBestandsnaam, "\"))).Close SaveChanges:=False
    'Opruimen dialoog object
    Set fd = Nothing
End Sub

 

[Elsendoorn2134]

Meppie1984

Om de macro wat sneller te maken kun je de volgende regels in het begin van de macro plaatsen:

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

En de volgende code aan het einde van de macro.

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

De eerste regel zorgt er voor dat de Excel het scherm tijdens het uitvoeren van de macro niet meer bijwerkt.
De tweede regel zorgt er voor dat Excel tijdens het verloop van de macro de cellen niet gaat berekenen.
Beide zorgen er voor dat Excel wat sneller is en dat het "knipperen" van het scherm stopt.

Niet vergeten om de laatste twee regels ook op te nemen anders kan je vreemde effecten krijgen.

Veel Succes.

 

[snb]

Misschien doe je er verstandiger aan het bronbestand als geheel te kopiëren en aan te passen.
Daarmee vermijd je al die trage kopieerakties.

gebruik bijv.

Sub M_snb()
   For j = 21 To 1 Step -1
       Columns(j).Resize(, 3).Insert
   Next
End Sub

 

[mieppie1984]

Ik heb hem eindelijk werken zoals de bedoeling is.
bedankt allemaal voor de hulp!