Antonius100
Gebruiker
- Lid geworden
- 2 dec 2008
- Berichten
- 9
Goedemorgen allen,
ik had een vraag om veranderingen van een totaalblad ook naar een detailblad te kopieeren.
Wat ik bedoel is dit;
Onderstaand staat een macro wat er voor zorgt dat, wanneer ik op de rechtermuisknop klik, de keuze krijg om een cel tussen al gevulde cellen in te voegen die zowel op het detail als totaalblad tevoor schijn komt
Ik heb een totaalblad, en een aantal detailbladen. Echter wil ik dat veranderingen meeveranderen als ik iets wijzig op het totaalblad of detailblad en andersom.
Het totaalblad is eigenlijk een samenvatting van een 15tal detailbladen.
Echter wil ik nu een macro maken die er voor zorgt dat via een rechtermuisklik in de plaats van invoegen nu de cel kopieert ( met opmaak ) en dan met de rechtermuisklik ook weer kan plakken tussen een cel waar ik voor kies.
Hopelijk snappen jullie wat ik bedoel, zoniet probeer ik het wat beter uit te leggen.
Met vriendelijke groet,
Teun
En
Ik denk dat de macro mijn verhaal iets duidelijker maakt.
ik had een vraag om veranderingen van een totaalblad ook naar een detailblad te kopieeren.
Wat ik bedoel is dit;
Onderstaand staat een macro wat er voor zorgt dat, wanneer ik op de rechtermuisknop klik, de keuze krijg om een cel tussen al gevulde cellen in te voegen die zowel op het detail als totaalblad tevoor schijn komt
Ik heb een totaalblad, en een aantal detailbladen. Echter wil ik dat veranderingen meeveranderen als ik iets wijzig op het totaalblad of detailblad en andersom.
Het totaalblad is eigenlijk een samenvatting van een 15tal detailbladen.
Echter wil ik nu een macro maken die er voor zorgt dat via een rechtermuisklik in de plaats van invoegen nu de cel kopieert ( met opmaak ) en dan met de rechtermuisklik ook weer kan plakken tussen een cel waar ik voor kies.
Hopelijk snappen jullie wat ik bedoel, zoniet probeer ik het wat beter uit te leggen.
Met vriendelijke groet,
Teun
Code:
Option Explicit
Const TotaalSheet As String = "totaal overzicht"
Const AfdelingRij As Integer = 1
Sub RegelToevoegen()
Dim HuidigeSheet As String, Rij As Long
Application.ScreenUpdating = False
HuidigeSheet = ActiveSheet.Name
Rij = ActiveCell.Row
If LCase(HuidigeSheet) = TotaalSheet Then
Dim Kolomstart As Integer, SheetNaam As String
Kolomstart = (Int((ActiveCell.Column - 1) / 3) * 3 + 1)
SheetNaam = Cells(AfdelingRij, Kolomstart).Value
If SheetExists(SheetNaam) Then 'totaalsheet
Range(Cells(Rij, Kolomstart), Cells(Rij, Kolomstart + 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Rij, Kolomstart), Cells(Rij, Kolomstart + 2)).Interior.ColorIndex = xlNone
Sheets(SheetNaam).Select
Range(Cells(Rij, "A"), Cells(Rij, "C")).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Rij, "A"), Cells(Rij, "C")).Interior.ColorIndex = xlNone
Else
MsgBox "Sheet: " & SheetNaam & " is niet in dit workbook aanwezig" & Chr(10) & _
"regel toevoegen niet uitgevoerd", vbCritical, "Fout gededecteerd"
End If
Else 'Sub sheets
If SheetExists(TotaalSheet) Then
Dim Kolom As Range
Range(Cells(Rij, "A"), Cells(Rij, "C")).Insert Shift:=xlShiftDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Rij, "A"), Cells(Rij, "C")).Interior.ColorIndex = xlNone
Sheets(TotaalSheet).Select
Set Kolom = Rows(AfdelingRij).Find(HuidigeSheet, LookIn:=xlValues)
If Kolom Is Nothing Then
MsgBox "Sheet: " & HuidigeSheet & " staat niet in sheet: " & TotaalSheet, vbCritical, "Fout gededecteerd"
Else
Range(Cells(Rij, Kolom.Column), Cells(Rij, Kolom.Column + 2)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(Rij, Kolom.Column), Cells(Rij, Kolom.Column + 2)).Interior.ColorIndex = xlNone
End If
Else
MsgBox "Sheet: " & TotaalSheet & " is niet in dit workbook aanwezig" & Chr(10) & _
"regel toevoegen niet uitgevoerd", vbCritical, "Fout gededecteerd"
End If
End If
Sheets(HuidigeSheet).Select
Application.ScreenUpdating = True
End Sub
Sub RegelVerwijderen()
Dim HuidigeSheet As String, Rij As Long
Application.ScreenUpdating = False
HuidigeSheet = ActiveSheet.Name
Rij = ActiveCell.Row
If LCase(HuidigeSheet) = TotaalSheet Then
Dim Kolomstart As Integer, SheetNaam As String
Kolomstart = (Int((ActiveCell.Column - 1) / 3) * 3 + 1)
SheetNaam = Cells(AfdelingRij, Kolomstart).Value
If SheetExists(SheetNaam) Then 'totaalsheet
Range(Cells(Rij, Kolomstart), Cells(Rij, Kolomstart + 2)).Delete Shift:=xlUp
Sheets(SheetNaam).Select
Range(Cells(Rij, "A"), Cells(Rij, "C")).Delete Shift:=xlUp
Else
MsgBox "Sheet: " & SheetNaam & " is niet in dit workbook aanwezig" & Chr(10) & _
"regel Verwijderen niet uitgevoerd", vbCritical, "Fout gededecteerd"
End If
Else 'Sub sheets
If SheetExists(TotaalSheet) Then
Dim Kolom As Range
Range(Cells(Rij, "A"), Cells(Rij, "C")).Delete Shift:=xlUp
Sheets(TotaalSheet).Select
Set Kolom = Rows(AfdelingRij).Find(HuidigeSheet, LookIn:=xlValues)
If Kolom Is Nothing Then
MsgBox "Sheet: " & HuidigeSheet & " staat niet in sheet: " & TotaalSheet, vbCritical, "Fout gededecteerd"
Else
Range(Cells(Rij, Kolom.Column), Cells(Rij, Kolom.Column + 2)).Delete Shift:=xlUp
End If
Else
MsgBox "Sheet: " & TotaalSheet & " is niet in dit workbook aanwezig" & Chr(10) & _
"regel verwijderen niet uitgevoerd", vbCritical, "Fout gededecteerd"
End If
End If
Sheets(HuidigeSheet).Select
Application.ScreenUpdating = True
End Sub
Private Function SheetExists(Sheetname As String) As Boolean
On Error Resume Next
Dim x As Object
SheetExists = False
Set x = ActiveWorkbook.Sheets(Sheetname)
If Err = 0 Then SheetExists = True
End Function
En
Code:
Option Explicit
Const Tagnaam As String = "Regel toevoegen"
Const Captionnaam1 As String = "Machine toevoegen"
Const Aktie1 As String = "RegelToevoegen"
Const Captionnaam2 As String = "Machine Verwijderen"
Const Aktie2 As String = "RegelVerwijderen"
Sub MenuToevoegen()
If Not Application.CommandBars("Cell").FindControl(Tag:=Tagnaam) Is Nothing Then Exit Sub
With Application.CommandBars("cell").Controls
With .Add(Type:=msoControlButton, Before:=1, temporary:=True)
.Caption = Captionnaam2
.OnAction = Aktie2
.Tag = Tagnaam
.FaceId = 292
End With
With .Add(Type:=msoControlButton, Before:=1, temporary:=True)
.Caption = Captionnaam1
.OnAction = Aktie1
.Tag = Tagnaam
.FaceId = 295
End With
End With
End Sub
Sub MenuVerwijderen()
On Error Resume Next
CommandBars("Cell").Controls(Captionnaam1).Delete
CommandBars("Cell").Controls(Captionnaam2).Delete
End Sub
Ik denk dat de macro mijn verhaal iets duidelijker maakt.