Bob Phillips
09-29-2010, 05:37 AM
You have to remove all of the Word objects anbd variables as well
Global appWord As Object
Global appDoc As Object
Global CellNordSyd As String
Global CellNyTotal As Variant
Global CellEksisTotal As Variant
Global CellHvilTotal As Variant
Global CellAnlaegsOmk As Variant
Global CellAnlaegsOmkForv As Boolean
Global CellAnlaegsOmkEnde As Boolean
Global CellAnlaegsOmkForvRange As range
Global CellAnlaegsOmkEndeRange As range
Global CellEksisRettighedAntal As Variant
Global CellTotal As Variant
Sub Transfer_to_Word()
'____________________________________________________________________
'^^^^^^^^^^^^^^^^^^ Open Word document ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Set appWord = CreateObject("Word.application")
Set appDoc = appWord.Documents.Open(Filename:=ThisWorkbook.Path & "\Tilbudsskabelon.docm")
appWord.Visible = True
Call AssignCells
Call AssignBookmarks
'***************** Create table for Ny installation *****************
If CellNyTotal <> 0 And (CellHvilTotal Or CellEksisTotal) <> 0 Then
Call CreateTable("Ny installation:", range("B21:F33"), "TblNyInst")
ElseIf CellNyTotal <> 0 And (CellHvilTotal And CellEksisTotal) = 0 Then
Call CreateTable("Ny installation:", range("B21:F31"), "TblNyInst")
End If
'***************** Create table for eksisterende installation *******
If CellEksisTotal <> 0 And (CellHvilTotal Or CellNyTotal) <> 0 Then
Call CreateTable("Eksisterende installation:", range("B37:F44"), "TblEksisInst")
ElseIf CellEksisTotal <> 0 And (CellHvilTotal And CellNyTotal) = 0 Then
Call CreateTable("Eksisterende installation:", range("B37:F42"), "TblEksisInst")
End If
'***************** Create table for Hvilende rettighed **************
If CellHvilTotal <> 0 And (CellEksisTotal Or CellNyTotal) <> 0 Then
Call CreateTable("Hvilende rettighed:", range("H21:L33"), "TblHvil")
ElseIf CellHvilTotal <> 0 And (CellEksisTotal And CellNyTotal) = 0 Then
Call CreateTable("Hvilende rettighed:", range("H21:L31"), "TblHvil")
End If
'***************** Create table for Anlægsomkostninger **************
If CellAnlaegsOmk <> 0 And CellAnlaegsOmkForv = True And CellAnlaegsOmkEnde = False Then
Call CreateTable("", range("B52:F52"), "TblAnlaeg")
ElseIf CellAnlaegsOmk <> 0 And CellAnlaegsOmkEnde = True Then
Call CreateTable("", range("B52:F52"), "TblAnlaeg")
End If
'***************** Create table for the total amount ****************
If CellTotal <> 0 Then
Call CreateTable("", range("B64:F70"), "TblTotal")
End If
'***************** Maksimize and put Word in front ******************
appDoc.Application.WindowState = xlMaximized
appDoc.Application.Activate
'***************** Release objects **********************************
Set appDoc = Nothing
Set appWord = Nothing
End Sub
Sub AssignCells()
CellNordSyd = ActiveWorkbook.Worksheets(1).range("C13").Value
CellEksisRettighedAntal = ActiveWorkbook.Worksheets(1).range("C37").Value
CellNyTotal = ActiveWorkbook.Worksheets(1).range("F33").Value
CellEksisTotal = ActiveWorkbook.Worksheets(1).range("F44").Value
CellHvilTotal = ActiveWorkbook.Worksheets(1).range("L33").Value
CellAnlaegsOmk = ActiveWorkbook.Worksheets(1).range("C15").Value
CellTotal = ActiveWorkbook.Worksheets(1).range("F70").Value
If RangeValue(range("L39:L47")) = True And RangeValue(range("L50:L58")) = False Then
CellAnlaegsOmkForv = True
ElseIf RangeValue(range("L50:L58")) <> 0 Then
CellAnlaegsOmkEnde = True
Else
CellAnlaegsOmkForv = False
CellAnlaegsOmkEnde = False
End If
End Sub
Sub AssignBookmarks()
appDoc.Bookmarks("Date").range.Text = Date
appDoc.Bookmarks("txtVedr").range.Text = ActiveWorkbook.Worksheets(1).range("B2")
appDoc.Bookmarks("txtAngaaende").range.Text = ActiveWorkbook.Worksheets(1).range("B5")
appDoc.Bookmarks("txtAar").range.Text = ActiveWorkbook.Worksheets(1).range("C14")
appDoc.Bookmarks("txtPtegning").range.Text = ActiveWorkbook.Worksheets(1).range("B8")
appDoc.Bookmarks("Date2mdr").range.Text = DateSerial(Year(Date), Month(Date) + 2, Day(Date))
appDoc.Bookmarks("txtUser").range.Text = ActiveWorkbook.Worksheets(1).range("B11")
End Sub
Private Function RangeValue(range As range) As Boolean
Dim ActiveRows As Integer
ActiveRows = 0
For i = 0 To range.Rows.Count 'Counts Active Rows
If range.Cells(i, 1).Value <> "" Then
ActiveRows = ActiveRows + 1
Else
ActiveRows = ActiveRows
End If
Next
If ActiveRows <> 0 Then
RangeValue = True
Else
RangeValue = False
End If
End Function
Private Function DefineProductStrings(Text As String, Antal As Variant, Pris As Variant, InvType As String) As String
Dim returnVal As String
If InvType = "Ny installation:" Then
If CellNordSyd = "NRGi Nord" Then
Select Case Text ' Return string to table
Case "Parcelhuse, fritidshuse, kolonihaver og erhverv. Egen stikledning"
returnVal = "Parcelhuse, fritidshuse, kolonihaver og erhverv. Egen stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Parcelhuse, fritidshuse, kolonihaver og erhverv. Fælles stikledning"
returnVal = "Parcelhuse, fritidshuse, kolonihaver og erhverv. Fælles stikledning." & vbCrLf & _
"1 stk. á " & Format(Pris, "##,##") & " kr. + " & Antal - 1 & " stk. * (" _
& Format(ActiveWorkbook.Worksheets(2).range("E16").Value, "##,##") & " kr. + (25 A * " & Format(ActiveWorkbook.Worksheets(2).range("E14").Value, "##,##") & " kr.)" & ")"
Case "Tæt lav bebyggelse, rækkehuse. Fælles Stikledning"
returnVal = "Tæt lav bebyggelse, rækkehuse. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Tæt lav bebyggelse, rækkehuse. Egen Stikledning"
returnVal = "Tæt lav bebyggelse, rækkehuse. Egen stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Lejligheder >2 etager. Fælles stikledning"
returnVal = "Lejligheder > 2 etager. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Ungdoms-, ældre- og plejebolig, højst på 65 m2. Fælles stikledning"
returnVal = "Ungdoms-, ældre- og plejeboliger. Max 65 m2. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Enfasede installation (< 1 kW)"
returnVal = "Enfasede installationer (< 1 kW)." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case 8
returnVal = 0
Case "Leveringsomfang ud over 25 ampere. Pr. ampere"
returnVal = "Leveringsomfang ud over 25 ampere." & vbCrLf & _
Antal & " ampere. á " & Format(Pris, "##,##") & " kr."
Case "Pr. kW"
returnVal = "Investeringsbidrag pr. kW." & vbCrLf & _
Antal & " kW. á " & Format(Pris, "##,##") & " kr."
Case "Fremtiddsikring af stikledning"
returnVal = "Fremtidssikring af stikledning." & vbCrLf & _
Antal & " ampere. á " & Format(Pris, "##,##") & " kr."
Case "Total"
returnVal = "Ialt."
End Select
ElseIf CellNordSyd = "NRGi Syd" Then
Select Case Text
Case "Parcelhuse, fritidshuse, kolonihaver og erhverv."
returnVal = "Parcelhuse, fritidshuse, kolonihaver og erhverv." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Tæt lav bebyggelse, rækkehuse (max 2 etager)"
returnVal = "Tæt lav bebyggelse, rækkehuse (max 2 etager)" & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Lejligheder >2 etager. Fælles stikledning"
returnVal = "Lejligheder > 2 etager. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Ungdoms-, ældre- og plejebolig, højst på 65 m2. Fælles stikledning"
returnVal = "Ungdoms-, ældre- og plejeboliger. Max 65 m2. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Enfasede installation (< 1 kW)"
returnVal = "Enfasede installationer (< 1 kW)." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case 8
returnVal = 0
Case "Leveringsomfang ud over 25 ampere. Pr. ampere"
returnVal = "Leveringsomfang ud over 25 ampere." & vbCrLf & _
Antal & " ampere. á " & Format(Pris, "##,##") & " kr."
Case "Pr. kW"
returnVal = "Investeringsbidrag pr. kW." & vbCrLf & _
Antal & " kW. á " & Format(Pris, "##,##") & " kr."
Case "Total"
returnVal = "Ialt."
End Select
End If
End If
If InvType = "Eksisterende installation:" Then
Select Case Text
Case "Udvidelse til ønskede rettighed (Ampere)"
returnVal = "Udvidelse til ønskede rettighed." & vbCrLf & _
"Fra " & CellEksisRettighedAntal & " A til " & Antal & " A til " & _
Format(Pris, "##,##") & " kr. pr. ampere."
Case "Fremtidssikring"
returnVal = "Fremtidssikring af stikledning." & vbCrLf & _
Antal & " A á " & Format(Pris, "##,##") & " kr."
Case "Stikledningsbidrag (25 ampere)"
returnVal = "Ved udskiftning af stikledning betales der:" & vbCrLf & _
"Stikledningsbidrag for de første 25 A."
Case "Ved udskiftning af stikledningbetales før udvidelsen"
returnVal = "Der betales " & Pris & " kr. pr. ampere udover de første 25 A før udvidelsen." & vbCrLf & _
Antal & " ampere á " & Format(Pris, "##,##") & " kr."
Case "Total"
returnVal = "Ialt."
End Select
End If
If InvType = "Hvilende rettighed:" Then
If CellNordSyd = "NRGi Nord" Then
Select Case Text
Case "Parcelhuse, fritidshuse, kolonihaver, erhverv"
returnVal = "Parcelhuse, fritidshuse, kolonihaver og erhverv." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Tæt lav bebyggelse, rækkehuse. Fælles Stikledning"
returnVal = "Tæt lav bebyggelse, rækkehuse. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Tæt lav bebyggelse, rækkehuse. Egen Stikledning"
returnVal = "Tæt lav bebyggelse, rækkehuse. Egen stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Lejligheder >2 etager. Fælles stikledning"
returnVal = "Lejligheder > 2 etager. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Ungdoms-, ældre- og plejebolig, højst på 65 m2. Fælles stikledning"
returnVal = "Ungdoms-, ældre- og plejeboliger. Max 65 m2. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Enfasede installation (< 1 kW)"
returnVal = "Enfasede installationer (< 1 kW)." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Leveringsomfang ud over 25 ampere. Pr. ampere"
returnVal = "Leveringsomfang ud over 25 ampere." & vbCrLf & _
Antal & " ampere. á " & Format(Pris, "##,##") & " kr."
Case "Pr. kW"
returnVal = "Investeringsbidrag pr. kW." & vbCrLf & _
Antal & " kW. á " & Format(Pris, "##,##") & " kr."
Case "Total"
returnVal = "Ialt."
End Select
ElseIf CellNordSyd = "NRGi Syd" Then
Select Case Text
Case "Parcelhuse, fritidshuse, kolonihaver, erhverv"
returnVal = "Parcelhuse, fritidshuse, kolonihaver og erhverv." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Tæt lav bebyggelse, rækkehuse (max 2 etager)"
returnVal = "Tæt lav bebyggelse, rækkehuse (max 2 etager)" & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Lejligheder >2 etager. Fælles stikledning"
returnVal = "Lejligheder > 2 etager. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Ungdoms-, ældre- og plejebolig, højst på 65 m2. Fælles stikledning"
returnVal = "Ungdoms-, ældre- og plejeboliger. Max 65 m2. Fælles stikledning." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Enfasede installation (< 1 kW)"
returnVal = "Enfasede installationer (< 1 kW)." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Leveringsomfang ud over 25 ampere. Pr. ampere"
returnVal = "Leveringsomfang ud over 25 ampere." & vbCrLf & _
Antal & " ampere. á " & Format(Pris, "##,##") & " kr."
Case "Pr. kW"
returnVal = "Investeringsbidrag pr. kW." & vbCrLf & _
Antal & " kW. á " & Format(Pris, "##,##") & " kr."
Case "Total"
returnVal = "Ialt."
End Select
End If
End If
If CellAnlaegsOmk <> 0 Then
If Text = "Anlægsomk.(c)" And CellAnlaegsOmkForv = True Then
returnVal = "Forventede anlægsomkostninger:"
ElseIf Text = "Anlægsomk.(c)" And CellAnlaegsOmkEnde Then
returnVal = "Endelig anlægsomokostninger:"
End If
End If
Select Case Text
Case "Nyt investeringsbidrag. ((b+l)-d)"
returnVal = "Nyt investeringsbidrag."
Case "Kundeandel af anlægsomk. (k)"
returnVal = "Kundeandel af anlægsomkostninger."
Case "Genopretning af installationer. (fastpris)"
returnVal = "Genopretning af installationer." & vbCrLf & _
Antal & " stk. á " & Format(Pris, "##,##") & " kr."
Case "Total ex. moms."
returnVal = ""
Case "Total ex. moms."
returnVal = ""
Case "25 % moms"
returnVal = "25 % moms."
Case "Total Incl. moms"
returnVal = "Ialt."
End Select
DefineProductStrings = returnVal
End Function
Private Function CreateNewTable(intRows As Integer, bookmark As String) As Object
' add a reference to the Word-library
Dim wrdTable As Object
Set wrdRange = appDoc.Bookmarks(bookmark).range
' appWord.Visible = True
'Create table
Set wrdTable = appDoc.Tables.Add(range:=wrdRange, NumRows:=intRows, NumColumns:=3)
'Set table width
wrdTable.Columns(3).Width = 70
wrdTable.Columns(2).Width = 20
wrdTable.Columns(1).Width = 320
Set CreateNewTable = wrdTable
End Function
Sub CreateTable(strHeader As String, colRange As range, bookmark As String)
Dim table As Object
Dim ActiveRows As Integer
Dim offSetRow As Integer
Dim rowCounter As Integer
Dim cellCounter As Integer
Dim krCounter As Integer
Dim sum As String
Dim dummy As String
Dim productType As String
Dim test As Integer
ActiveRows = 0
krCounter = 0
cellCounter = 1
offSetRow = 1
rowCounter = 1
If strHeader <> "" Then
ActiveRows = 1
Else
ActiveRows = 0
End If
For i = 0 To colRange.Rows.Count 'Counts Active Rows
If colRange.Cells(i, 5).Value <> "" And colRange.Cells(i, 5).Value <> 0 Then
ActiveRows = ActiveRows + 1
Else
ActiveRows = ActiveRows
End If
Next
Set table = CreateNewTable(ActiveRows, bookmark) 'Create Table
With table 'Insert Header string
If strHeader <> "" Then
With .Cell(1, 1).range
.InsertAfter strHeader
.Underline = 1
offSetRow = 2
End With
End If
For Each Cell In colRange
Select Case True
Case cellCounter Mod 5 = 0 'if cellcounter modolus 5 = 0 transfer activecell value to sum
sum = Cell
Case cellCounter Mod 4 = 0
dummy = Cell
Case cellCounter Mod 3 = 0
price = Cell
Case cellCounter Mod 2 = 0
nummer = Cell
Case cellCounter Mod 1 = 0
productType = Cell
End Select
If cellCounter Mod 5 = 0 Then
If (Len(sum) <> 0 And Len(sum) <> 1) And sum <> "" Then
With .Cell(offSetRow, 1).range
.InsertAfter DefineProductStrings(productType, nummer, price, strHeader) 'Insert string text
End With
With .Cell(offSetRow, 2).range
If krCounter = 0 Or DefineProductStrings(productType, nummer, price, strHeader) = "Ialt." Then
.InsertAfter "kr. "
If bookmark <> "TblTotal" Then
If strHeader <> "" Then
If ActiveRows = offSetRow And ActiveRows <> 2 Then 'Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
End If
End If
ElseIf bookmark = "TblTotal" Then
If ActiveRows - 3 = offSetRow Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
ElseIf ActiveRows = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
.ParagraphFormat.Borders(-3).LineStyle = 7
End If
End If
Else
.InsertAfter " - "
If bookmark = "TblTotal" Then
If ActiveRows - 3 = offSetRow Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
End If
End If
End If
krCounter = krCounter + 1
End With
With .Cell(offSetRow, 3).range
If krCounter = 0 Or DefineProductStrings(productType, nummer, price, strHeader) = "Ialt." Then
.InsertAfter Format(sum, "##,##0.00") 'Insert sum
' .ParagraphFormat.Alignment = wdAlignParagraphRight
.ParagraphFormat.Alignment = 2
If bookmark <> "TblTotal" Then
If strHeader <> "" Then
If ActiveRows = offSetRow Then 'Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
End If
End If
ElseIf bookmark = "TblTotal" Then
If ActiveRows - 3 = offSetRow Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
ElseIf ActiveRows = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleDouble
.ParagraphFormat.Borders(-3).LineStyle = 7
End If
End If
Else
.InsertAfter Format(sum, "##,##0.00") 'Insert sum
.ParagraphFormat.Alignment = wdAlignParagraphRight
If bookmark = "TblTotal" Then
If ActiveRows - 3 = offSetRow Or ActiveRows - 1 = offSetRow Then
' .ParagraphFormat.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.ParagraphFormat.Borders(-3).LineStyle = 1
End If
End If
End If
End With
End If
cellCounter = 0
If (Len(sum) <> 0 And Len(sum) <> 1) And sum <> "" Then
offSetRow = offSetRow + 1
Else
offSetRow = offSetRow
End If
End If
cellCounter = cellCounter + 1
Next
rowCounter = rowCounter + 1
For Each myRow In .Rows
For Each myCell In myRow.Cells
myCell.TopPadding = Application.CentimetersToPoints(0)
myCell.BottomPadding = Application.CentimetersToPoints(0)
myCell.LeftPadding = Application.CentimetersToPoints(0)
myCell.RightPadding = Application.CentimetersToPoints(0)
Next
Next
End With
End Sub
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.