waarden uit Wordtabel copy-pasten naar juiste rij en Excel

[StijnVL]

Hallo allemaal,


Ik heb het volgende probleem: ik heb een 80-tal Word-documenten, waarin telkens dezelfde tabel staat (uiteraard met andere waarden). Ik zou al deze tabellen in een Excelbestand willen samenvoegen.


Kort gezegd komt het hierop neer:
Word: cel1 = naam student, cel2 = titel eindwerk, cel3 = naam stagebedrijf.
Excel (Blad1): kolomA: namen studenten (reeds ingevuld), kolomB: titels eindwerken (voorlopig leeg), kolomC: namen stagebedrijven

Ik wou in VBA de volgende routine schrijven:
Wordbestand1openen ==> alles kopiëren ==> Excel activeren (Blad2) ==> Plakken ==> waarde uit (Blad2)cel1 (= naam student) opzoeken in (Blad1)kolomA ==> waarden uit (Blad2)cel2 en cel3 copy-pasten in de overeenstemmende Rij in Blad1 ==> Wordbestand2openen ==> alles kopiëren ==> in Excel (Blad2) op dezelfde plaats plakken als hierboven enz...


Het copy-pasten lukt me wel via VBA, wat lukt me nog niet:
het openen van telkens het volgende Wordbestand (zolang er Wordbestanden in de map staan)
het opzoeken van de naamStudent in Blad1, en de gegevens in de overeenstemmende rij plakken.


Hopelijk ben ik wat duidelijk, en weet er iemand raad?
Alvast bedankt!
Stijn.

 

[Relleboer]

Macro om te zoeken en gegevens te kopieeren

Sub zoeken1()
 Dim Sk As Range
    rij = 1
    h = 1
    Do
        With Worksheets("Blad1").Range("b1:b5000")
         Set c = .Find(Cells(rij, 1), LookIn:=xlValues)
         If Not c Is Nothing Then
             firstAddress = c.Address
             Do
                  
                      
               ' jouw bewerking  
               
             Set c = .FindNext(c)
             Loop While Not c Is Nothing And c.Address <> firstAddress
         End If
         End With
    rij = rij + 1
    Loop Until Cells(rij, 1).Value = Empty
    
End Sub

COde voor bestanden openen in map

Sub grafieken()
Dim lCount As Long
Dim wbResults As Workbook
Dim wbCodeBook As Workbook

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False

On Error Resume Next

Set wbCodeBook = ThisWorkbook

    With Application.FileSearch
        .NewSearch
         'bestands adres wijzegen na de goede
        .LookIn = "C:\Documents and Settings\Lab\Mijn documenten\Data voor grafieken"
        .FileType = msoFileTypeExcelWorkbooks
        .Filename = "*.csv"
        
            If .Execute > 0 Then 'wekboeken in folder
                For lCount = 1 To .FoundFiles.Count 'Loop door alle mappen.
                 'Open Workbook x and Set a Workbook variable to it
                 Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                                  
          'jouw bewerking
        
                 wbResults.Close SaveChanges:=False
             
                 Next lCount
            End If
    End With
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
End Sub

Hopelijk kom je verder met deze codes