Avatar billede MSR Juniormester
02. november 2021 - 14:02

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?
Avatar billede Ny bruger Nybegynder

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.

Loading billede Opret Preview
Kategori
Vi har et stort udvalg af Excel kurser. Find lige det kursus der passer dig lige her.

Log ind eller opret profil

Hov!

For at kunne deltage på Computerworld Eksperten skal du være logget ind.

Det er heldigvis nemt at oprette en bruger: Det tager to minutter og du kan vælge at bruge enten e-mail, Facebook eller Google som login.

Du kan også logge ind via nedenstående tjenester