Mon denne macro ikke kan bruges
Option Explicit
Dim ws As Worksheet, wsKopi_1 As Worksheet, wsKopi_2 As Worksheet, wsKopi_3 As Worksheet, wsKopi_4 As Worksheet
Dim rArea As Range, MyArray(), NewArray()
Dim iRow, iColumn
Dim A, B, C As Integer
Sub MyCopy()
Set ws = Sheets("Ark1") ' ret Ark1 til hvad dit ark hedder
Set wsKopi_1 = Sheets("Ark2")
Set wsKopi_2 = Sheets("Ark3")
Set wsKopi_3 = Sheets("Ark4")
Set wsKopi_4 = Sheets("Ark5")
Set rArea = ws.UsedRange 'Sætter rArea lig det brugte område på arket "ws"
MyArray = rArea.Value ' Sætter Array'et MyArray lig rArea
'----- Sætter størelsen på NewArray ------
C = 2
B = 1
For iColumn = LBound(MyArray, 2) To UBound(MyArray, 2) 'Løber kolonnerne igennem
For iRow = LBound(MyArray, 1) To UBound(MyArray, 1) 'Løber rækker igennem
Select Case iColumn
Case 1
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 1 her mindre end 300
C = C + 1
End If
Case 2
If MyArray(iRow, iColumn) < 200 Then ' betingelse for kolonne 2 her mindre end 200
C = C + 1
End If
Case 3
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 3
C = C + 1
End If
Case 4
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 4
C = C + 1
End If
End Select
Next iRow
If C > A Then A = C
C = 0
B = B + 1
Next iColumn
ReDim NewArray(2 To 2 + A + 1, 1 To 1 + B)
'-------//-------
A = 2
B = 1
'------- Finder data der skal over -------
For iColumn = LBound(MyArray, 2) To UBound(MyArray, 2) 'Løber kolonnerne igennem
For iRow = LBound(MyArray, 1) To UBound(MyArray, 1) 'Løber rækker igennem
Select Case iColumn
Case 1
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 1 her mindre end 300
NewArray(A, B) = MyArray(iRow, iColumn)
A = A + 1
End If
Case 2
If MyArray(iRow, iColumn) < 200 Then ' betingelse for kolonne 2 her mindre end 200
NewArray(A, B) = MyArray(iRow, iColumn)
A = A + 1
End If
Case 3
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 3
NewArray(A, B) = MyArray(iRow, iColumn)
A = A + 1
End If
Case 4
If MyArray(iRow, iColumn) < 300 Then ' betingelse for kolonne 4
NewArray(A, B) = MyArray(iRow, iColumn)
A = A + 1
End If
End Select
Next iRow
A = 2
B = B + 1
Next iColumn
'------//-----
'----- Overfører data -----
For iColumn = LBound(NewArray, 2) To UBound(NewArray, 2) 'Løber kolonnerne igennem
For iRow = LBound(NewArray, 1) To UBound(NewArray, 1) 'Løber rækker igennem
Select Case iColumn
Case 1
wsKopi_1.Cells(iRow, 1).Value = NewArray(iRow, iColumn)
Case 2
wsKopi_2.Cells(iRow, 1).Value = NewArray(iRow, iColumn)
Case 3
wsKopi_3.Cells(iRow, 1).Value = NewArray(iRow, iColumn)
Case 4
wsKopi_4.Cells(iRow, 1).Value = NewArray(iRow, iColumn)
End Select
Next iRow
Next iColumn
End Sub
Jan
