Her er lidt at lege med:
(Kan med garanti gøres kønnere)
Public Sub InputBoxValg()
Dim Svar As String
If Not SheetExists("Total") Then
Sheets.Add.Name = "Total"
Ark1.Activate
Range("A1:D1").Select
Selection.Copy
Sheets("Total").Select
Range("A1").Select
ActiveSheet.Paste
Range("E1").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "Total:"
Range("F1").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(9,C[-2])"
End If
Ark1.Activate
Svar = InputBox("Hvilken kunde?")
Ark1.Activate
With Worksheets("Ark1")
If Not .AutoFilterMode Then
.Range("A1").AutoFilter
End If
.EnableAutoFilter = True
End With
Selection.AutoFilter Field:=1, Criteria1:=Svar
Range("A2:D50").Select
Selection.Copy
Sheets("Total").Select
Range("A2").Select
If Range("A2").Value = "" Then
Range("A2").Activate
Else
Range("A2").CurrentRegion.Select
ActiveCell.Offset(Selection.Rows.Count, 0).Activate
End If
With ActiveCell
ActiveSheet.Paste
Range("A1").Select
End With
Ark1.Activate
ActiveSheet.ShowAllData
Range("A1").Activate
Ark2.Activate
With Worksheets("Ark2")
If Not .AutoFilterMode Then
.Range("A1").AutoFilter
End If
.EnableAutoFilter = True
End With
Selection.AutoFilter Field:=1, Criteria1:=Svar
Range("A2:D50").Select
Selection.Copy
Sheets("Total").Select
Range("A2").Select
If Range("A2").Value = "" Then
Range("A2").Activate
Else
Range("A2").CurrentRegion.Select
ActiveCell.Offset(Selection.Rows.Count, 0).Activate
End If
With ActiveCell
ActiveSheet.Paste
Range("A1").Select
End With
Ark2.Activate
ActiveSheet.ShowAllData
Range("A1").Activate
Ark3.Activate
With Worksheets("Ark3")
If Not .AutoFilterMode Then
.Range("A1").AutoFilter
End If
.EnableAutoFilter = True
End With
Selection.AutoFilter Field:=1, Criteria1:=Svar
Range("A2:D50").Select
Selection.Copy
Sheets("Total").Select
Range("A2").Select
If Range("A2").Value = "" Then
Range("A2").Activate
Else
Range("A2").CurrentRegion.Select
ActiveCell.Offset(Selection.Rows.Count, 0).Activate
End If
With ActiveCell
ActiveSheet.Paste
Range("A1").Select
Ark1.Activate
End With
Ark3.Activate
ActiveSheet.ShowAllData
Range("A1").Activate
Sheets("Total").Select
End Sub
Public Function SheetExists(ByRef SheetName As String) As Boolean
On Error Resume Next
SheetExists = ActiveWorkbook.Worksheets(SheetName).Index
End Function
Og ser så nu, at du udvider med flere ark?
Så skal der en ekspert på til at lave 'genneløb' af ark, som jeg ikke kan.
