Søge og kopiere fra et faneblad til et andet

Den må du lige forklare lidt nærmere. Står nummeret først, tilfældigt midt i eller i slutningen af cellen? Vil du have kopieret cellen eller værdien. Hvordan vil du angive hvad du søger efter: i en celle eller i en tekstbox?

nummeret står altid først og gerne i en text box

nummeret i faneblad Tal står altid først og gerne i en text box

Denne skulle virke:

Private Sub CommandButton1_Click()
zz = Range("A2:A6000")
L = UBound(zz)
step = 1
Range("A2").Select
    t = "1"
For I = 1 To L
    If Left(zz(I, 1), 1) = t Then
        step = step + 1
        Sheets("204").Select
        Range("A" & step).Select
        ActiveCell.Value = zz(I, 1)
        Sheets("Tal").Select
    End If
Next
End Sub

Kan optimeres hvis den tager lang tid!

Det var da noget sludder jeg fik lagt ind:

Private Sub CommandButton1_Click()
Sheets("Tal").Select
zz = Range("A2:A6000")
L = UBound(zz)
step = 1
t = "1"
R = Len(t)
Sheets("204").Select
For I = 1 To L
    If Left(zz(I, 1), R) = t Then
        step = step + 1
        Range("A" & step).Select
        ActiveCell.Value = zz(I, 1)
    End If
Next
End Sub

Med inputbox:

Private Sub CommandButton1_Click()

Dim step As Long

Sheets("Tal").Select



  Dim a As Long, response As Long

  t = Application.InputBox( _

      Prompt:="Skriv tallet du søger", _

      Title:="Find nummeret du skriver:", Type:=2)

  If t <> False Then



zz = Range("A2:A6000")

L = UBound(zz)

R = Len(t)

Sheets("204").Select

For I = 1 To L

    If Left(zz(I, 1), R) = t Then

        step = step + 1

        Sheets("204").Range("A" & step).Select

        ActiveCell.Value = zz(I, 1)

    End If

Next

  End If



End Sub

ok men hvor skal jeg lægge det hen ?

Jeg regner med at du vil have det aktiveret med en knap.
Højreklik på værktøjslinien, øverst i Excel og sæt flueben ud for "kontrolelementer"... eller gå til "Vis" -> "Værktøjslinier" -> "kontrolelementer".

Du får nu en værktøjslinie frem. Klik på en kommandoknap og klik der på arket hvor du vil have knappen. Dobbeltklik på knappen. Du kommer nu ind i Visual basic hvor der vil stå:

Private Sub CommandButton1_Click()

End Sub

Kopier ovenstående tekst, på nær øverste og nederste linie (de er en gentagelse), så der i alt står:

Private Sub CommandButton1_Click()
Dim step As Long

Sheets("Tal").Select
  Dim a As Long, response As Long
  t = Application.InputBox( _
      Prompt:="Skriv tallet du søger", _
      Title:="Find nummeret du skriver:", Type:=2)
  If t <> False Then

zz = Range("A2:A6000")
L = UBound(zz)
R = Len(t)
Sheets("204").Select
For I = 1 To L
    If Left(zz(I, 1), R) = t Then
        step = step + 1
        Sheets("204").Range("A" & step).Select
        ActiveCell.Value = zz(I, 1)
    End If
Next
  End If
End Sub


Gå tilbage til regnearket, og klik på ikonet med en linial, trekant, og blyant, så denne ikke længere er fremhævet (den findes på værktøjslinien "kontrolelementer")

Jeg kunne godt tænke mig at der var en knap man trykkede på i faneblad 204 så inputboxen kommer og man kan intaste det man søger efter

Det er det du har i ovenstående!

ok så er det klaret, men den kopier ikke noget til faneblad 204 når jeg skriver det nummer der svarer til nummer i faneblad Tal A rækken

Hvis du skriver

1aaa
2bbb
1ccc
3ddd
1eee

.. i celle A2:A6, trykker på knappen og skriver et 1-tal?

så sker der ikke noget ?

Du har vel ikke deaktiveret makroer. har du en hotmail, så kan jeg sende dig et ark?

Sorry det virker hvis jeg laver knappen i Faneblad Tal ! men ville godt have knappen i Faneblad 204, kan man det ?

Det kan godt være jeg vil have række B med fra Faneblad Tal sammen med række A ?

Ja, da. Du laver bare en tilsvarende knap i det nye ark.

Her er en lidt mere optimeret kode:

Private Sub CommandButton1_Click()
Dim step As Long
Dim a As Long, response As Long
t = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)
If t <> False And IsNumeric(t) Then

zz = Sheets("Tal").Range("A2:A6000")
L = UBound(zz)
R = Len(t)

For I = 1 To L
    If Left(zz(I, 1), R) = t And Not IsNumeric(Mid(zz(I, 1), R + 1, 1)) Then
        step = step + 1
        Sheets("204").Range("A" & step).Select
        ActiveCell.Value = zz(I, 1)
    End If
Next
 
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

Jeg ved godt jeg er lidt besværlig men kan det også lade sig gøre at den skriver ind i Faneblad 204 fra A2 og ikke fra A1, der har jeg en overskrift ?

Ovenstående var svar på Kommentar: scharff
01/09-2006 13:18:40

Det kan godt laves så kolonne B kommer med!

det virker bare fjong ! men så var der lige det med række 2 og at den ikke skriver i A1

Ups Række B ikke 2

Private Sub CommandButton1_Click()
Dim step As Long
Dim a As Long
t = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)
If t <> False And IsNumeric(t) Then

step = 1
zz = Sheets("Tal").Range("A2:B6000")
L = UBound(zz)
Q = 2 'LBound(zz)
R = Len(t)
    For S = 1 To Q
        For I = 1 To L
            If Left(zz(I, S), R) = t And Not IsNumeric(Mid(zz(I, S), R + 1, 1)) Then
                step = step + 1
                Sheets("204").Range("A" & step).Select
                ActiveCell.Value = zz(I, S)
            End If
        Next
  Next
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

den kopier ikke række B med over sammen med Række A ? jeg får en fejl der hedder Runtime Error '9'
Subscript out of range

Det lyder som om du er stødt på en grænse. Prøv at trykke "Debug" næste gang, og se hvor i koden du ender.

Hmm det var måske fordi jeg havde rettet zz = Sheets("Tal").Range("A2:B6000")til L2:L6000 for det var ikke A2 i faneblad Tal men L2 den skulle kikke i og skrive det ind i A2 på faneblad 204 ! er det noget der kan rettes ?

der er også flere kolonner jeg gerne vil have kopieret over sammen med det der står i A eks. kolonne B skal kopieres over i D på faneblad 204 ?

Virker det med A2:B6000?

Skal jg forstå det således at kolonne a-Tal skal til b-204 og b-Tal til c-204. Hvor skal kolonne L fra Tal så? I kolonne M i 204?

ja det virker med A2:B6000, men ikke at den kopier kolonne b !
nej den skal søge i L2-tal istedet for A2-tal og stadig skrive det ind i A2-204(men det kunne jeg løse ved at flytte data fra L-tal til a-tal.)

jeg mener at c-Tal skal skrives i d-204 ! jeg skal have flere kolonner over i 204 men regner med at det kunne jeg bare selv finde udaf hvis jeg bare har den første.

Prøv denne. Det virker altså ok her. Det eneste du skal ændre er dit range. Der kan stå hvadsomhelst, bare du ikke kommer over kolonne IV:

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
MitRange = Sheets("Tal").Range("A2:B6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array
RaekkeTal = UBound(MitRange, 2) 'finder bredden på dit array
Application.ScreenUpdating = False 'slår skærmopdatering fra
LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For s = 1 To RaekkeTal 'tæller hvor mange kolonner der skal gennemløbes
        For I = 1 To KolonneTal
            If Left(MitRange(I, s), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, s), LTal + 1, 1)) Then
                step = step + 1
                IAlt = IAlt + 1
                Sheets("204").Cells(2, 1).Select
                Sheets("204").Cells(step + 1, s).Value = MitRange(I, s)
            End If
        Next
    step = 0
  Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
Range("A1").Select
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

Prøvede lige med 20.000 tal i 13 kolonner - fra A2 til M20000. Der blev fundet ca. 98.000 værdier på ca. 13 sek.

Du skal lige ændre
Sheets("204").Cells(step + 1, s).Value = MitRange(I, s)
til
Sheets("204").Cells(step + 1, s + 1).Value = MitRange(I, s)
for at rykke en kolonne til højre

hmm ! den kopier ikke c-Tal over i d-204 sammen med A

Hmmm, nu er jeg slet ikke med??? Skal tallene fra kolonne A og C samlet i kolonne D???

læste du Kommentar: akyhne
01/09-2006 16:03:25?

det kan godt være det er mig der ikke kan finde udaf at fortælle hvad det er jeg gerne vil have ! men jeg intaster et nummer i tekstboxen og den kikker i a2-tal så skal den kopiere alt med det nummer over i a2-204 og derned af + den også tager det der står i c-tal med over i d-204 og derned af ! var det bedre eller er jeg langt ude og du fatter bjelle :-)

Det jeg har lavet putter
ark "Tal" - kolonne A til ark "204" - kolonne B
ark "Tal" - kolonne B til ark "204" - kolonne C
ark "Tal" - kolonne C til ark "204" - kolonne D
o.s.v.

hmm der kommer kun noget i a-204 når den finder det rigtige nummer

Altså...
Du klikker på knappen og får en inputbox. Du skriver et nummer, f.eks 77.
Koden løber A2-A6000 igennem for at finde alle celler der starter med 77.
Hver gang den finder et match, kopieres denne celles indhold samt indholdet i celle C til et nyt ark i kolonne D, således at værdien i A og C bindes sammen i celle D.

Du skal kun have løbet kolonne A igennem!
Er dette rigtigt forstået?

Jeg ved ikke om jeg måtte få dit tlf. nummer på mail så vil jeg gerne ringe til dig, er måske lidt nemmere ! hvis ikke så prøver jeg at skrive her igen ! min mail adresse er scharff_peter@yahoo.dk

det skal være sådan at jeg klikker på knappen og får en inputbox. jeg skriver et nummer, f.eks 77.
Koden løber A2-A6000 igennem for at finde alle celler der starter med 77.
Hver gang den finder et match, kopieres denne celles indhold samt indholdet i celle C til ark 204 i kolonne D hvor den også skriver i kolonne A

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange


'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
MitRange = Sheets("Tal").Range("A2:C6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array
'RaekkeTal = UBound(MitRange, 2) 'finder bredden på dit array
Application.ScreenUpdating = False 'slår skærmopdatering fra
LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    'For s = 1 To RaekkeTal 'tæller hvor mange kolonner der skal gennemløbes
        For I = 1 To KolonneTal
            If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
                step = step + 1
                IAlt = IAlt + 1
                'Sheets("204").Cells(2, 1).Select
                Sheets("204").Cells(step + 1, 4).Value = MitRange(I, 1) & MitRange(I, 2)
            End If
        Next
    'step = 0
  'Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
Range("A1").Select
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

Eller sådan:


Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange


'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
MitRange = Sheets("Tal").Range("A2:C6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array
'RaekkeTal = UBound(MitRange, 2) 'finder bredden på dit array
Application.ScreenUpdating = False 'slår skærmopdatering fra
LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    'For s = 1 To RaekkeTal 'tæller hvor mange kolonner der skal gennemløbes
        For I = 1 To KolonneTal
            If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
                step = step + 1
                IAlt = IAlt + 1
                'Sheets("204").Cells(2, 1).Select
                Sheets("204").Cells(step + 1, 4).Value = MitRange(I, 1) & MitRange(I, 3)
                Sheets("204").Cells(step + 1, 1).Value = MitRange(I, 1)
            End If
        Next
    'step = 0
  'Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
Range("A1").Select
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

nu sker der noget men den skal ikke lægge cellerne sammen

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange


'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
MitRange = Sheets("Tal").Range("A2:E6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array
'RaekkeTal = UBound(MitRange, 2) 'finder bredden på dit array
Application.ScreenUpdating = False 'slår skærmopdatering fra
LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    'For s = 1 To RaekkeTal 'tæller hvor mange kolonner der skal gennemløbes
        For I = 1 To KolonneTal
            If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
                step = step + 1
                IAlt = IAlt + 1
                'Sheets("204").Cells(2, 1).Select
                Sheets("204").Cells(step + 1, 1).Value = MitRange(I, 1)
                Sheets("204").Cells(step + 1, 2).Value = MitRange(I, 2)
                Sheets("204").Cells(step + 1, 3).Value = MitRange(I, 4)
                Sheets("204").Cells(step + 1, 4).Value = MitRange(I, 5)
            End If
        Next
    'step = 0
  'Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
Range("A1").Select
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

Ja det er bare kanon det virker sku !! 1000 tak for hjælpen
kan man auto få lavet et faneblad med det nummer man skriver i tekstboxen så den laver det den skal i det nye faneblad den lige har opretet ?

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange
Set NewSheet = Worksheets.Add
NewSheet.Range("A1").Value = "Nummer"
NewSheet.Range("B1").Value = "Navn"
NewSheet.Range("C1").Value = "Gade"
NewSheet.Range("D1").Value = "By"

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:E6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    'For s = 1 To RaekkeTal 'tæller hvor mange kolonner der skal gennemløbes
        For I = 1 To KolonneTal
            If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
                step = step + 1
                IAlt = IAlt + 1
                NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
                NewSheet.Cells(step + 1, 2).Value = MitRange(I, 2)
                NewSheet.Cells(step + 1, 3).Value = MitRange(I, 4)
                NewSheet.Cells(step + 1, 4).Value = MitRange(I, 5)
            End If
        Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("A1").Select

Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If
Sheets("204").Select
End Sub

det er helt vildt hvor skrap du er til det her det virker bare kanon !!
men så bliver man jo krævene, jeg har et faneblad ny hvor sideopsætningen og alle kolonner og celler er i de rigtige størelser dem ville jeg gerne have overført til det nye nummer ark der bliver lavet ? er jeg for vild nu :-)

Hmmm, du trækker kraftigt på de sølle 60 point. Du må give lidt mere ved lejlighed :-) ... og nej, jeg er intet i forhold til de hårde guttere som bak, kabbak, sjap, jkrons, janvogt, flemmingdahl, erikjuul m.m. som har hjulpet mig før, og laver løsninger på 1/20 del af den tid jeg tager om det.

Angående dit spm. Kan du specificere/uddybe lidt mere? Er det cellefarver, kanter (rammer), og cellestørrelser vi snakker om? Er alle celler i kolonne A ens, i kolonne B ens, o.s.v.
Mail evt. et udsnit til mig.

hele arket skal bare være magen til også sideopsætningen som det faneblad der hedder ny ! den skal vel "bare" kopiere arket ny og så rette det til det nummer der selv kommer.

Jeg ved ikke om du gider hjælpe mig mere, men der er lidt mere ?
jeg ville godt lave så den soter i celle C2 indtil den møder en tekst inaktiv kunde så skal den lave 5 tomme rækker ovenover og bagefter sortere fra D? hvor teksten inaktiv kunde begynder ?
jeg ved ikke om der skal laves en ny knap eller om du kan putte den ind den anden ?

du skal nok få mange flere point !

Hvis der er mange forskellige formateringer i arket kunne det være en ide, blot at kopiere et standard ark som i forvejen er defineret, men det er nu ikke svært at lave via VBA

Her er hvordan du kopierer et ark kaldet "ny". Det er lavet så dette ark er skjult. Du skal have oprettet dette ark før du kører noget kode, eller i det hele taget lukker Excelfilen. Du kan, hvis du skal redigere i arket, kalde det frem på 2 måder: Luk dit ark på krydset i Excel, og klik "Annuller" - IKKE "nej" ellr "ja"!!! 2. metode er at gå ind i VBA-editoren, markére arket kaldet "ny" i "Projekt-VBAProjekt"-vinduet, kig i vinduet "Properties". Der er et felt der hedder "visible". Klik hvor der står "0 - XLSheetHidden", og sæt den til 1.


Sæt denne kode ind i ThisWorkbook:

Private Sub Workbook_BeforeClose(Cancel As Boolean)
Sheets("ny").Visible = True
End Sub

Private Sub Workbook_Open()
Sheets("ny").Visible = False
ActiveWorkbook.Sheets("Tal").Tab.ColorIndex = 43
ActiveWorkbook.Sheets("204").Tab.ColorIndex = 43
ActiveWorkbook.Sheets("ny").Tab.ColorIndex = 3
End Sub


Den nye kode til din CommandButton ser således ud:

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange

Sheets("ny").Copy After:=Sheets("204")
Set NewSheet = ActiveSheet
NewSheet.Visible = True
NewSheet.Range("A1").Value = "Nummer"
NewSheet.Range("B1").Value = "Navn"
NewSheet.Range("C1").Value = "Gade"
NewSheet.Range("D1").Value = "By"

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:E6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For I = 1 To KolonneTal
        If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
            step = step + 1
            IAlt = IAlt + 1
            NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
            NewSheet.Cells(step + 1, 2).Value = MitRange(I, 2)
            NewSheet.Cells(step + 1, 3).Value = MitRange(I, 4)
            NewSheet.Cells(step + 1, 4).Value = MitRange(I, 5)
        End If
    Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("A1").Select

Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If
Sheets("204").Select
End Sub

Kommentar: scharff
02/09-2006 01:08:19

Altså sortere celleområdet A2:D6000 i det nye ark? eller bare løbe kolonne C igennem efter en tekst kaldet "inaktiv" og indsætte 5 tomme rækker over?

Sidstnævnte er i hvertfald meget nemt, men jeg stopper for i dag (nat). Konen står snart med kagerullen bag mig ;-)

den skal først sortere D kolonnen i det nye ark den selv har lavet og så bagefter skal den finde inaktiv kunde og sætte 5 tomme rækker ovenover bagefter skal den så sortere kolonne d igen men kun fra der hvor der starter med inaktiv kunde

i stedet for den bare selv laver et nyt ark så skal den kopiere arket ny og bruge det.

det med kopi af faneblad ny virker, så nu er det bare at få den til at sortere :-)

Det med sortering må du uddybe. Der kan sorteres på mange måder. Hvis du vil sortere hele området i det nye ark med kolonne D som gældende faktor, indsætter du denne kode:

ActiveCell.SpecialCells(xlLastCell).Select 'Finder nederste celle der er skrevet i
NedersteCelle = ActiveCell.Row

NewSheet.Range("D2:D" & NedersteCelle + 1).Select
Range("A1:D" & NedersteCelle + 1).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

... imellem disse 2 linier:

NewSheet.Range("A1").Select

Application.ScreenUpdating = True

Hvor skal der søges efter inaktiv kunde (kolonne), og hvilken tekst (nøjagtig) skal der søges på?

min fejl ! der skal kun sortere en gang bagefter skal den finde alle dem hvor der står inaktiv kunde og flytte dem til bunden af arket + 5 tomme rækker ovenover og rykke de andre rækker op til der hvor den har flyttet alle de rækker med inaktiv kunde.

den skal også søge i kolonne d efter inaktiv kunde

Prøv denne. Den søger både i kolonne C og D i dit nye ark efter teksten "inaktiv kunde":

Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange

Sheets("ny").Copy After:=Sheets("204")
Set NewSheet = ActiveSheet
NewSheet.Visible = True
NewSheet.Range("A1").Value = "Nummer"
NewSheet.Range("B1").Value = "Navn"
NewSheet.Range("C1").Value = "Gade"
NewSheet.Range("D1").Value = "By"

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:E6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For I = 1 To KolonneTal
        If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
            step = step + 1
            IAlt = IAlt + 1
            NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
            NewSheet.Cells(step + 1, 2).Value = MitRange(I, 2)
            NewSheet.Cells(step + 1, 3).Value = MitRange(I, 4)
            NewSheet.Cells(step + 1, 4).Value = MitRange(I, 5)
        End If
    Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select 'Finder nederste celle der er skrevet i
NedersteCelle = ActiveCell.Row

NewSheet.Range("D2:D" & NedersteCelle + 1).Select
Range("A1:D" & NedersteCelle + 1).Sort Key1:=Range("D2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Spring5 = 6
For FindInaktive = 2 To NedersteCelle
    If UCase(NewSheet.Range("D" & FindInaktive).Value) = "INAKTIV KUNDE" Or UCase(NewSheet.Range("C" & FindInaktive).Value) = "INAKTIV KUNDE" Then
        NewSheet.Rows(FindInaktive & ":" & FindInaktive).Select
        Selection.Cut
        NewSheet.Range("A" & NedersteCelle + Spring5).Select
        Selection.Insert Shift:=xlDown
        Spring5 = Spring5 + 5
        FindInaktive = FindInaktive - 1
    End If
Next
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If
Sheets("204").Select
End Sub

Sorry! Sorteringen var gået fløjten :-(


Private Sub CommandButton1_Click()
Dim step, a, Q, L As Long
Dim MitRange

Sheets("ny").Copy After:=Sheets("204")
Set NewSheet = ActiveSheet
NewSheet.Visible = True
NewSheet.Range("A1").Value = "Nummer"
NewSheet.Range("B1").Value = "Navn"
NewSheet.Range("C1").Value = "Gade"
NewSheet.Range("D1").Value = "By"

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:E6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For I = 1 To KolonneTal
        If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
            step = step + 1
            IAlt = IAlt + 1
            NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
            NewSheet.Cells(step + 1, 2).Value = MitRange(I, 2)
            NewSheet.Cells(step + 1, 3).Value = MitRange(I, 4)
            NewSheet.Cells(step + 1, 4).Value = MitRange(I, 5)
        End If
    Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select 'Finder nederste celle der er skrevet i
NedersteCelle = ActiveCell.Row

NewSheet.Range("D2:D" & NedersteCelle + 1).Select 'vælger det område der er værdier i
NewSheet.Range("A1:D" & NedersteCelle + 1).Sort Key1:=NewSheet.Range("D2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Spring5 = 6
For FindInaktive = 2 To NedersteCelle
    If UCase(NewSheet.Range("D" & FindInaktive).Value) = "INAKTIV KUNDE" Or UCase(NewSheet.Range("C" & FindInaktive).Value) = "INAKTIV KUNDE" Then
        NewSheet.Rows(FindInaktive & ":" & FindInaktive).Select
        Selection.Cut
        NewSheet.Range("A" & NedersteCelle + Spring5).Select
        Selection.Insert Shift:=xlDown
        Spring5 = Spring5 + 5
        FindInaktive = FindInaktive - 1
    End If
Next
test:
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If
Sheets("204").Select
End Sub

Hej igen ! jeg kan ikke få det der til at virke med at når den finder en tekst Med Inaktiv Kunde i Kolonne M (den var d før )så skal den flytte dem ned i bunden og lave 5 tomme rækker over ?

Koden checker i kolonne C og D. Det var det jeg havde forstået!
Du retter bare her:

If UCase(NewSheet.Range("D" & FindInaktive).Value) = "INAKTIV KUNDE" Or UCase(NewSheet.Range("C" & FindInaktive).Value) = "INAKTIV KUNDE" Then

Range("D" og Range("C"
ændres til det det nu skal være.
Range("M"

det har jeg prøvet men det virker ikke den sorterer fint men den laver ikke noget med at flytte alle dem der står Inaktiv Kunde i ?

Jamen vent lige lidt. Der st[r jo heller ikke noget i kolonne M p[ det ark vi opretter. kun i kolonne A til D!!!

jeg har udvidet det så der er fra A til N og det med inaktiv Kunde er nu i M

Jamen vent lige lidt. Der står jo heller ikke noget i kolonne M på det ark vi opretter. kun i kolonne A til D!!!

Sådan ser den ud nu hvis du kan gennemskue det ! det skulle være rigtigt nok tror jeg :-)

Private Sub CommandButton3_Click()
Dim step, a, Q, L As Long
Dim MitRange

Sheets("ny").Copy After:=Sheets("tal")
Set NewSheet = ActiveSheet
NewSheet.Visible = True

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:p6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For I = 1 To KolonneTal
        If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
            step = step + 1
            IAlt = IAlt + 1
            Sheets("Ny").Cells(step + 1, 1).Value = MitRange(I, 1)
                NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
                NewSheet.Cells(step + 1, 3).Value = MitRange(I, 14)
                NewSheet.Cells(step + 1, 4).Value = MitRange(I, 3)
                NewSheet.Cells(step + 1, 5).Value = MitRange(I, 4)
                NewSheet.Cells(step + 1, 6).Value = MitRange(I, 5)
                NewSheet.Cells(step + 1, 7).Value = MitRange(I, 6)
                NewSheet.Cells(step + 1, 8).Value = MitRange(I, 7)
                NewSheet.Cells(step + 1, 9).Value = MitRange(I, 8)
                NewSheet.Cells(step + 1, 10).Value = MitRange(I, 9)
                NewSheet.Cells(step + 1, 11).Value = MitRange(I, 10)
                NewSheet.Cells(step + 1, 12).Value = MitRange(I, 11)
                NewSheet.Cells(step + 1, 13).Value = MitRange(I, 12)
                NewSheet.Cells(step + 1, 14).Value = MitRange(I, 16)
           
        End If
    Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("A1").Select
ActiveCell.SpecialCells(xlLastCell).Select 'Finder nederste celle der er skrevet i
NedersteCelle = ActiveCell.Row

NewSheet.Range("m2:m" & NedersteCelle + 1).Select 'vælger det område der er værdier i
NewSheet.Range("A1:n" & NedersteCelle + 1).Sort Key1:=NewSheet.Range("m2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

Spring5 = 6
For FindInaktive = 2 To NedersteCelle
    If UCase(NewSheet.Range("M" & FindInaktive).Value) = "Inaktiv kunde" Or UCase(NewSheet.Range("M" & FindInaktive).Value) = "Inaktiv Kunde" Then
        NewSheet.Rows(FindInaktive & ":" & FindInaktive).Select
        Selection.Cut
        NewSheet.Range("A" & NedersteCelle + Spring5).Select
        Selection.Insert Shift:=xlDown
        Spring5 = Spring5 + 5
        FindInaktive = FindInaktive - 1
    End If
Next
test:
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

End Sub

men den virker stadig ikke med det der Inaktiv Kunde ?

Ret "Inaktiv Kunde" til "INAKTIV KUNDE"!

ucase() sætter teksten til store bogstaver. Det er for at du får resultatet med uanset om du har skrevet

Inaktiv kunde
Inaktiv KUNDE
eller
inaktiv kunde

En ekstra sikkerhed :-)

Der er også en fejl i din sortering:

NewSheet.Range("m2:m" & NedersteCelle + 1).Select 'vælger det område der er værdier i
NewSheet.Range("A1:n" & NedersteCelle + 1).Sort Key1:=NewSheet.Range("m2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

skal være

NewSheet.Range("M2:M" & NedersteCelle + 1).Select 'vælger det område der er værdier i
NewSheet.Range("A2:N" & NedersteCelle + 1).Sort Key1:=NewSheet.Range("M2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

ok så er det rettet men det virker stadig ikke ? efter den har sorteret kolonne M så er den bare markeret ?

Det virker her.
I det ark du har, får du genereret et nyt faneblad. lad os kalde det "1".

I det faneblad er der data i kolonne A-N. I kolonne M er der i nogle celler en tekst der hedder "Inaktiv Kunde".
Korrekt?

yep

Jeg har sendt et ark på din yahoo mail.

hmm der ser det ud til at virke men der skal kun være en gang 5 tomme rækker. men hvorfor virker det ikke i mit ark ? Kan det være fordi jeg skjuler kolonne A ?

"Kan det være fordi jeg skjuler kolonne A ?"
Nej, det er Excel ligeglad med.

Prøv med en ny knap med min kode!

Skift

Spring5 = Spring5 + 5

ud med

'Spring5 = Spring5 + 5

...så er der kun 1 gange mellemrum

har lige sendt dig noget

har du kikket på det ? virker det ikke mærkeligt at det ikke virker ?

et forslag


Public Sub HentTal()
    Dim RaaData As Variant, R As Long, C As Long, StrTal As String, Res() As Variant, I As Long
    I = 0
    StrTal = InputBox("Indtast søgekreterie")
    RaaData = Sheets("Tal").Range("A2:A6000")
    For R = LBound(RaaData, 1) To UBound(RaaData, 1)
        For C = LBound(RaaData, 2) To UBound(RaaData, 2)
            If Not IsNumeric(RaaData(R, C)) Then
                If InStr(RaaData(R, C), StrTal) Then
                    ReDim Preserve Res(I)
                    Res(I) = RaaData(R, C)
                    I = I + 1
                End If
            End If
        Next
    Next
    Sheets("204").Select
    Sheets("204").Range("A2:A" & UBound(Res) + 2) = Application.WorksheetFunction.Transpose(Res)
End Sub

måske bedre sådan

Public Sub HentTal()
    Dim RaaData As Variant, R As Long, C As Long, StrTal As String, Res As Variant, I As Long
    I = 1
    StrTal = InputBox("Indtast søgekreterie")
    Sheets("204").Range("A2:A6000").ClearContents
    Res = Sheets("204").Range("A2:A6000")
    RaaData = Sheets("Tal").Range("A2:A6000")
    For R = LBound(RaaData, 1) To UBound(RaaData, 1)
        For C = LBound(RaaData, 2) To UBound(RaaData, 2)
            If Not IsNumeric(RaaData(R, C)) Then
                If InStr(RaaData(R, C), StrTal) Then
                    Res(I, 1) = RaaData(R, C)
                    I = I + 1
                End If
            End If
        Next
    Next
    Sheets("204").Select
    Range("A2:A6000") = Res
End Sub

hmm det andet som akyhne har lavet virker sku lækkert men der er kun lige det sidste (måske :-) ) med de Inaktive kunder som den skal klippes og sættes ned i bunden med 5 tomme rækker ovenover dem .

det kunne måske være nemmere at den bare kikker kolonne M igennem og når den møder den første række med teksten Inaktive Kunder så sætter den 5 tomme rækker ind ovenover ?

Sorry, var lige til forældremøde. Problemet var at teksten i kolonne M står således "Inaktiv Kunde    " & ikke sådan "Inaktiv Kunde"

Retter nu, samt en anden "fejl"!

lækkert

hvis jeg sætter de 4 mellemrum efter INAKTIV KUNDE så går den helt i stå og der sker ikke noget ??

Det skal du heller ikke. fik du min mail?

Jeg ved ikke om du får dataene fra en database eller... koden sørger for, kun at læse de første 13 tegn i cellerne i kolonnen "M"

"INAKTIV KUNDE" er 13 tegn incl. mellemrum.

yep den ser nice ud og ser pt ud som om den virker men kikker på det i morgen foreløbig tak for hjælpen.

Jeg har lige sendt dig en mail :-)

den jeg har sendt dig er der måske stadig lidt med sorteringen prøv at kikke i M2 den er ikke rigtig ?

Putter lige koden.

Dim MitRange

Sheets("ny").Copy After:=Sheets("tal")
Set NewSheet = ActiveSheet
NewSheet.Visible = True

'FindTal sætte til den værdi du skriver
FindTal = Application.InputBox( _
Prompt:="Skriv tallet du søger", _
Title:="Find nummeret du skriver:", Type:=2)

If FindTal <> False And IsNumeric(FindTal) Then 'checker om du skrev noget og om det er et tal. "And IsNumeric(FindTal)" skal udelukkes hvis du vil kunne søge på andet end tal
Fejl = 0
For Each ws In Worksheets 'går alle arknavne igennem
If ws.Name = FindTal Or Left(ws.Name, 6 + Len(FindTal)) = (FindTal & " (Kopi") Then 'hvis arknavn findes tælles op
    Fejl = Fejl + 1
End If
Next
If Fejl > 0 Then
    NewSheet.Name = FindTal & " (Kopi" & Fejl & ")"
Else
    NewSheet.Name = FindTal
End If

MitRange = Sheets("Tal").Range("A2:P6000") 'laver et array ved navn MitRange
KolonneTal = UBound(MitRange) 'finder længden på dit array


Application.ScreenUpdating = False 'slår skærmopdatering fra

LTal = Len(FindTal) 'finder ud af hvor langt tallet er
    For I = 1 To KolonneTal
        If Left(MitRange(I, 1), LTal) = FindTal And Not IsNumeric(Mid(MitRange(I, 1), LTal + 1, 1)) Then
            step = step + 1
            IAlt = IAlt + 1
            Sheets("Ny").Cells(step + 1, 1).Value = MitRange(I, 1)
                NewSheet.Cells(step + 1, 1).Value = MitRange(I, 1)
                NewSheet.Cells(step + 1, 3).Value = MitRange(I, 14)
                NewSheet.Cells(step + 1, 4).Value = MitRange(I, 3)
                NewSheet.Cells(step + 1, 5).Value = MitRange(I, 4)
                NewSheet.Cells(step + 1, 6).Value = MitRange(I, 5)
                NewSheet.Cells(step + 1, 7).Value = MitRange(I, 6)
                NewSheet.Cells(step + 1, 8).Value = MitRange(I, 7)
                NewSheet.Cells(step + 1, 9).Value = MitRange(I, 8)
                NewSheet.Cells(step + 1, 10).Value = MitRange(I, 9)
                NewSheet.Cells(step + 1, 11).Value = MitRange(I, 10)
                NewSheet.Cells(step + 1, 12).Value = MitRange(I, 11)
                NewSheet.Cells(step + 1, 13).Value = MitRange(I, 12)
                NewSheet.Cells(step + 1, 14).Value = MitRange(I, 16)
           
        End If
    Next

MsgBox ("Der blev overført " & IAlt & " celleværdier.")
NewSheet.Range("B1").Select

NewSheet.Range("M1:M" & NedersteCelle + 1).Select 'vælger det område der er værdier i
NewSheet.Range("A1:N" & NedersteCelle + 1).Sort Key1:=NewSheet.Range("M2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

For FindInaktive = 2 To IAlt + 1
    If UCase(Left(NewSheet.Range("M" & FindInaktive - Minus).Value, 13)) = "INAKTIV KUNDE" Then
        NewSheet.Rows(FindInaktive - Minus & ":" & FindInaktive - Minus).Select
        Selection.Cut
        NewSheet.Range("A" & IAlt + 7).Select
        Selection.Insert Shift:=xlDown
        Minus = Minus + 1
    End If
Next
test:
Application.ScreenUpdating = True
Else
    MsgBox "Du skrev ikke et tal!" & vbLf _
    & "Jeg stopper her :-)"
End If

har oprettet et nyt spørgsmål http://www.eksperten.dk/spm/730484 ! der er stadig noget med M2 den er ikke sorteret rigtigt