Hallo,
Onderstaande de code die ik voor het bestand reeds heb geschreven. Alleen wat in de cel F16 "TEST" staat weet ik de code in vba niet als er meerdere lijnen met gegevens zijn.
Bedankt.
Dim fn As Variant
Dim sPoints As String
Dim nEindRij As Integer
Dim mEindeRij As Integer
Dim i As Long
Dim strBestand As String
Dim wbIZ As Workbook
Dim wbPoints As Workbook
Dim laatsteR As Integer
If LCase(ActiveWorkbook.Name) Like "*points*" Then 'controleren of de point wel actief is
Set wbPoints = ActiveWorkbook
MsgBox ("open het bestand IZ_PC.xlsx van het kantoor in de map Basisdocumenten")
fn = Application.GetOpenFilename("Excel-files,*.xls*;*.xlsx", 1, "Select One File To Open", , False)
If TypeName(fn) = "Boolean" Then Exit Sub
Workbooks.Open fn
Sheets("Points IZ_GU").Select
Cells.Select
Selection.Copy
wbPoints.Activate
Sheets("detail IZ_GU").Select
Cells.Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Workbooks.Open fn
Application.CutCopyMode = False
ActiveWorkbook.Close
' Zoekt de eerste cel met waarde NUL
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveWorkbook.Sheets("detail IZ_GU")
For i = 100 To 1 Step -1
If .Cells(i, "E") = "0" Then
.Cells(i, "E").EntireRow.ClearContents
End If
Next i
End With
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
If Sheets("detail IZ_GU").Range("C65520").End(xlUp).Value = "Totaal" Then
nEindRij = Sheets("detail IZ_GU").Range("C65520").End(xlUp).Row
Else
nEindRij = Sheets("detail IZ_GU").Range("C65520").End(xlUp).Offset(1).Row
End If
Cells(nEindRij, "C") = "Totaal"
Columns("D
").Select
Selection.Delete Shift:=xlToLeft
Range(Cells(nEindRij, "D"), Cells(nEindRij, Range("C4").End(xlToRight).Column)).FormulaR1C1 = "=SUM(R5C:INDEX(C,ROW()-1)) "
Range("D5").End(xlDown).Offset(0, 3).Value = " Totaal te verdelen onder het aanvraagtype EnvEnr.... in tabblad Points" & " " & " ***** Total � r�partir sous les types de demandes EnvEnr.... dans le fichier Points"
Range("D5").End(xlDown).Offset(0, 3).Font.Bold = True
Range("D5").End(xlDown).Offset(0, 3).Font.Size = 12
Range("D5").End(xlDown).Offset(0, 3).Font.Color = RGB(255, 255, 255)
Range("D5").End(xlDown).Offset(0, 3).Interior.Color = RGB(50, 120, 204)
Range(Cells(nEindRij, "D"), Cells(nEindRij, Range("C4").End(xlToRight).Column)).FormulaR1C1 = "=SUM(R5C:INDEX(C,ROW()-1)) "
Columns("G:G").EntireColumn.AutoFit
Rows("4:4").Select
Selection.AutoFilter
Cells(1, 7).Select
Selection.End(xlDown).Select
laatsteR = Selection.Row
ActiveCell.Offset(0, -1).Select
ActiveCell.Value = "test"
ActiveCell.Offset(1, 1).Select
ActiveCell.Value = "Totaal reeds verdeeld onder het aanvraagtype EnvEnr.... in tabblad Points" & " " & " ***** Total d�j� r�parti sous les types de demandes EnvEnr.... dans le fichier Points"""
ActiveCell.Font.Bold = True
ActiveCell.Font.Size = 12
ActiveCell.Font.Color = RGB(255, 255, 255)
ActiveCell.Interior.Color = RGB(85, 26, 139)
' open template detail_IZ_GU Template.xlsx
strBestand = DataManagers\Patrick\Distributie 2012\detail_IZ_GU Template.xlsx
Set wbIZ = Workbooks.Open(strBestand)
Sheets("detail IZ_GU").Select
Columns("G:G").Select
Selection.Copy
wbPoints.Activate
Sheets("detail IZ_GU").Select
Columns("F:F").Select
Selection.Insert Shift:=xlToRight
Columns("F:F").EntireColumn.AutoFit
Range("G22").Select
Range("F4").Comment.Shape.Select True
Selection.ShapeRange.IncrementLeft 112.5
Selection.ShapeRange.IncrementTop -39#
Application.CutCopyMode = False
wbIZ.Close True
Else
MsgBox "Points niet actief"
End If
End Sub
