Kopiering af rækker til nyt ark
Jeg har tyvstjålet og tilpasset følgende:Sub CopyRows()
Dim lRow As Long
Dim lCol As Long
Dim lCount As Long
Dim rInputTable As Range
Dim rTarget As Range
Dim arInput()
Dim arOutput()
Dim vPattern As Variant
Dim ws As Worksheet
Dim mySheet As Variant
mySheet = "MA"
Application.DisplayAlerts = False
For Each ws In ThisWorkbook.Worksheets
If mySheet = ws.Name Then
ws.Delete
End If
Next ws
Application.DisplayAlerts = True
On Error GoTo ErrorHandle
vPattern = InputBox("Angiv søgestreng/værdi" & vbNewLine _
& "Du kan bruge jokere til mønstre:" & vbNewLine & vbNewLine _
& "? Enhver enkelt karakter" & vbNewLine _
& "* Nul eller flere karakterer", "Identifikator")
If Len(vPattern) = 0 Then Exit Sub
Set rInputTable = Range("A7").CurrentRegion
arInput = rInputTable.Value
Set rInputTable = Nothing
ReDim arOutput(1 To UBound(arInput), 1 To UBound(arInput, 2))
For lRow = 1 To UBound(arInput)
If arInput(lRow, 4) Like vPattern Then
lCount = lCount + 1
For lCol = 1 To UBound(arInput, 2)
arOutput(lCount, lCol) = arInput(lRow, lCol)
Next
End If
Next
If lCount = 0 Then
MsgBox "Ingen rækker opfyldte søgekriteriet."
GoTo BeforeExit
End If
ThisWorkbook.Sheets.Add(after:=Sheets("Navneoversigt")).Name = "MA"
Sheets("1BTN").Range("A6:BH6").Copy Destination:=Sheets("MA").Range("A2")
Range("A1").Select
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
"'1BTN'!A1", TextToDisplay:="Tilbage"
Set rTarget = Range("A3").Resize(UBound(arOutput), UBound(arOutput, 2))
rTarget.Value = arOutput
BeforeExit:
On Error Resume Next
Set rTarget = Nothing
Erase arInput
Erase arOutput
Exit Sub
ErrorHandle:
MsgBox Err.Description & " Procedure CopyRows"
Resume BeforeExit
End Sub
Alt virker rigtigt fint, bortset fra:
Den leder kun efter værdier i kolonne 4 ( If arInput(lRow, 4) og det skal være kolonne 1-100 (altså samtlige kolonner en ad gangen)
Ligeledes kopierer den al tekst, men ikke formateringen og specielt farvede celler.
Kan det fikses?
Jeg ved godt det er småsnedigt at rode i noget man ikke selv har lavet, men det kan næsten præcis det jeg skal bruge og så virker det tosset at lave det helt selv.
Jeg håber nogen kan hjælpe?