26. april 2016 - 09:32Der er
6 kommentarer og 1 løsning
2 regneark der samles i et 3. med mulighed for tilføjelse af data
Hej
Jeg skal have lavet et regne"ark" hvor Ark2 og 3 indeholder en række kolonner med forskelligt indhold. der skal kunne tilføjes nye rækker som skal duplikeres over i ark 1 som så bliver en live oversigt af de 2 andre.
det er lidt underordnet om det er formel eller makro for mig. der er allerede en oversigtslinje i begge ark som ikke behøver at komme med (hvert fald ikke 2 gange).
Jeg tænker orden er underordnet da man kan vælge at sortere efter produktnavn, Varenummer etc. efterfølgende.
Når du selv vil have fingrene i det, vil jeg foreslå, at du laver en makro, der først markerer dataområdet på ark2 og kopierer det til ark1; og derefter markerer dataområdet på ark3, og kopierer det til første tomme række under på ark 1.
Hvis du ikke bruge de øverste rækker på fanebladene kan du på hvert faneblad oprette en makroknap, der eksekverer den samme makro.
Rem Version (005)_1 Option Explicit Dim totalArkRæk As Integer, aktuelleArk As String, flagNyOpret As Boolean Private Sub Workbook_BeforeClose(Cancel As Boolean) ProtectMe "TJI" ProtectMe "Mekaniker Værkstedet" End Sub
Private Sub Workbook_Open() Sheets("Tji total").Activate End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object) If (Sh.Name = "TJI" Or Sh.Name = "Mekaniker Værkstedet") Then 'fjern beskyttelse UnProtectMe Sh.Name End If End Sub
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim formel As String Application.ScreenUpdating = False
If (Sh.Name = "TJI" Or Sh.Name = "Mekaniker Værkstedet") And InStr(Target.Address, ":") = 0 And _ (ActiveSheet.Range("I" & Target.Row) = "" Or flagNyOpret = True) Then 'Ej ind i kode hvis markerig ikke er 1 celle eller Tidsreg.udfyldt If Target.Row > 1 Then If Target.Column < 9 Then UnProtectMe Sh.Name If Target.Value = "" Then Target.Value = 0 ElseIf Target.Value = 0 Then Sh.Cells(Target.Row, 9).Value = "" Else Sh.Cells(Target.Row, 9).Value = Now() flagNyOpret = True End If
If erCellerUdfyldt(Target.Row) = True Then UnProtectMe Sh.Name aktuelleArk = Sh.Name
Rem - indsæt ny række i "bunden" af Total ark indsætNyRække Sheets(aktuelleArk).Activate
Range("A" & Target.Row & ":H" & Target.Row).Copy
Rem Opdater Tji-Total Sheets("Tji total").Activate
Rem Opbyg skema i totalark for indsatte række afsætSkema totalArkRæk
Rem Indsæt formel i kolonne C (Antal), der peger på "kildeark" formel = "=" & "'" & aktuelleArk & "'!" & "C" & Target.Row ActiveSheet.Range("C" & totalArkRæk + 1).Formula = formel
Rem Marker nyoprettelse som afsluttet flagNyOpret = False
Rem Vend tilbage til ajf. ark Sheets(aktuelleArk).Activate Application.CutCopyMode = False ProtectMe Sh.Name End If End If End If End If End Sub
Private Sub indsætNyRække() Sheets("Tji total").Activate totalArkRæk = Cells(Rows.Count, "A").End(xlUp).Row 'ActiveCell.SpecialCells(xlLastCell).Row ActiveSheet.Rows(totalArkRæk + 1 & ":" & totalArkRæk + 1).Select Selection.Insert Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove End Sub
Private Function erCellerUdfyldt(række) Dim cc For Each cc In Range("A" & række & ":H" & række).Cells If IsEmpty(cc) = True Then If cc.Column <> 5 Then erCellerUdfyldt = False cc.Interior.ColorIndex = 3 Exit Function End If Else cc.Interior.ColorIndex = xlNone End If Next cc erCellerUdfyldt = True End Function
Private Sub afsætSkema(ræk) With ActiveSheet .Range("A" & ræk & ":H" & ræk).Select Selection.Copy .Range("A" & ræk + 1).Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End With End Sub
Public Sub ProtectMe(ByRef sSheet As String) Sheets(sSheet).Protect Password:="TITest1234" End Sub
Public Sub UnProtectMe(ByRef sSheet As String) Sheets(sSheet).Unprotect Password:="TITest1234" End Sub
Public Sub resetExcel() Application.EnableEvents = True ActiveSheet.EnableCalculation = True Application.ScreenUpdating = True End Sub
Synes godt om
Ny brugerNybegynder
Din løsning...
Tilladte BB-code-tags: [b]fed[/b] [i]kursiv[/i] [u]understreget[/u] Web- og emailadresser omdannes automatisk til links. Der sættes "nofollow" på alle links.