Jeg har et regneark, som indeholder en liste med personer. Hver person
har (self.) et navn og et personnummer. Personerne er delt op i
grupper, og hver person har derfor også et gruppenummer. Mit problem
er, at jeg gerne vil flette Excel-dokumentet til et Word-dokument, hvor
der udskrives et ark for hver gruppe. Jeg kan kun finde ud af at
flette, hvis der kun skal en person på hvert ark, men det er jo ikke
tilfældet her. Er der noget helt basalt, jeg overser, eller kan det
ikke lade sig gøre?
Mvh.
Henny
Hej igen Henny
Her er en makro, der skulle løse dit problem, men da
jeg ikke har set dit hoveddokument, er det muligt, at
vi skal korrespondere lidt for at få det til at køre
I Excel:
Jeg har forudsat, at overskrifterne står i række 1, og
data i række 2 og nedefter.
1. Åbn din datakilde (projektmappen)
2. Markér hele gruppekolonnen (klik i A'et)
3. Klik i navneboksen (yderst til venstre for indtastningslinjen)
4. Skriv navnet "Grupper" uden anførselstegn.
5. Gem projektmappen og luk den.
(Makroen nedenfor sorterer datalisten efter gruppenummer.)
I Word:
1. Åbn dit hoveddokument.
2. Gå til VBA-editoren med <Alt><F11>
3. Find dit hoveddokument i projektvinduet til venstre
og dobbeltklik på det. Hvis projektvinduet ikke er
synligt, får du det frem med <Ctrl>r
4. Vælg menupunktet Indsæt > Modul
5. Kopiér subrutinen nedenfor og indsæt den i modulet.
6. Vælg menupunktet Funktioner > Referencer
7. Find Microsoft Excel Object Library og sæt hak ved det.
8. Gå tilbage til hoveddokumentet med <Alt><F11>, gem
det og luk det
I brug:
1. Åben dit hoveddokument.
2. Vælg <Ctrl><F8> og kør makroen "FletningMedGruppe"
Hver gruppe vil nu blive placeret i sit eget dokument, hvorfra
du kan udskrive på almindelig vis.
Option Explicit
Sub FletningMedGruppe()
'Leo Heuser, 29-4-2006
Dim ActDocument As Document
Dim Counter As Long
Dim Dummy As Variant
Dim DummyRange As Excel.Range
Dim EndRecordColl As New Collection
Dim GetBackSlash As Long
Dim GroupRange As Excel.Range
Dim GroupRangeName As String
Dim GroupRangeValue As Variant
Dim SheetName As String
Dim StartRecordColl As New Collection
Dim XLApp As Excel.Application
Dim XLWorkbook As Excel.Workbook
On Error GoTo Finito
GroupRangeName = "Grupper"
Dummy = ActiveDocument.MailMerge.DataSource.Name
GetBackSlash = InStr(Dummy, "\")
Do While GetBackSlash <> 0
Dummy = Mid(Dummy, GetBackSlash + 1)
GetBackSlash = InStr(Dummy, "\")
Loop
Set XLApp = GetObject(, "Excel.Application")
Set XLWorkbook = XLApp.Workbooks(Dummy)
Set GroupRange = XLApp.Range(GroupRangeName)
With XLWorkbook.Worksheets(GroupRange.Parent.Name)
Set GroupRange = XLApp.Range(GroupRange.Cells(1, 1), _
.Cells(.Rows.Count, GroupRange.Column).End(xlUp))
End With
GroupRange.Cells(1, 1).Sort _
key1:=GroupRange, order1:=xlAscending, header:=xlYes, _
MatchCase:=False
Set GroupRange = GroupRange.Rows(2). _
Resize(GroupRange.Rows.Count - 1, GroupRange.Columns.Count)
GroupRangeValue = GroupRange.Value
On Error Resume Next
For Counter = 1 To UBound(GroupRangeValue)
StartRecordColl.Add Item:=Counter, _
Key:=CStr(GroupRangeValue(Counter, 1))
Next Counter
For Counter = 1 To UBound(GroupRangeValue) - 1
EndRecordColl.Add Item:=StartRecordColl(Counter + 1) - 1, _
Key:=CStr(StartRecordColl(Counter + 1))
Next Counter
EndRecordColl.Add Item:=UBound(GroupRangeValue, 1)
On Error GoTo Finito
Set ActDocument = ActiveDocument
For Counter = 1 To StartRecordColl.Count
With ActDocument.MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = StartRecordColl(Counter)
.LastRecord = EndRecordColl(Counter)
End With
.Execute
End With
Next Counter
Finito:
If Err.Number <> 0 Then
MsgBox "Der er opstået følgende fejl." & vbNewLine & _
Err.Description
End If
Set XLApp = Nothing
Set XLWorkbook = Nothing
End Sub
--
Med venlig hilsen
Leo Heuser
Followup to newsgroup only please.