Kako naj vrstice z določeno vsebino premaknem na konec lista

[PaPaDiZ]

Koda: Izberi vse

myValue = "Vm"
    myValue1 = "De"
    
    EndRow = Cells(Rows.Count, 2).End(xlUp).Row
    If Check_Val_Existence(myValue, "B1:B" & EndRow) = True Or Check_Val_Existence(myValue1, "B1:B" & EndRow) = True Then
       Sheets(mySheetName).Select
       Range("A1").EntireRow.Select
       Selection.Copy
       Range("A" & EndRow + 3).Select
       Selection.Insert Shift:=xlDown
       
       For i = EndRow To 2 Step -1
           If Range("B" & i).Value = myValue Or Range("B" & i).Value = myValue1 Then
              Range("A" & i).EntireRow.Select
              Selection.Cut
              ZadnjaVrstica = Cells(Rows.Count, 2).End(xlUp).Row
              Range("A" & ZadnjaVrstica).Select
              Selection.Insert Shift:=xlUp
              Range("A" & i).EntireRow.Delete
           End If
       Next i
    End If

Zgornja koda naj bi vrstice z določeno vsebino v B stolpcu premaknila tri vrstice nižje od zadnje uporabljene vrstice, vendar nekaj ne deluje pravilno. Prosim za pomoč.

Hvala

[kljuka13]

Kakšno napako pa vam javi? Aha torej tukaj notri se skrivajo sklici na neke funkcije, ki jih seveda ni.

Koda: Izberi vse

Sub premakniCelice()
Dim i
i = 1
Do While Not Range("B" & i).Value = ""
    i = i + 1
Loop
Range("B1:B" & i).Select
Selection.Cut Destination:=Range("B" & i & ":B10")
Range("B1").Select
End Sub

[PaPaDiZ]

Ne javi napake, samo ne deluje tako kot sem si zamislil

[admin]

Če želite, da bi vam kdo pomagal, morate povedati več informacij, ter podati releventen del programske kode. V vašem primeru manjka programska koda funkcije Check_Val_Existence ter seveda opis napake, na kar vas je opozoril že kljuka.

Pravite da ne javi napake a ne deluje tako kot pričakujete. Od kot pa ste dobili kodo in kaj tam piše, da naj bi delala?

[PaPaDiZ]

Koda: Izberi vse

Function Check_Val_Existence(ByVal sText, ByVal sRange) As Boolean

Dim rFnd As Range
Dim sTxt As String

Set rFnd = ActiveSheet.Range(sRange).Find(What:=sText, LookAt:=xlPart)
If Not rFnd Is Nothing Then
Check_Val_Existence = True
Else
Check_Val_Existence = False
End If

End Function
.
.
.
.
.

   myValue = "Vm"
   myValue1 = "De"
   
    EndRow = Cells(Rows.Count, 2).End(xlUp).Row
    If Check_Val_Existence(myValue, "B1:B" & EndRow) = True Or Check_Val_Existence(myValue1, "B1:B" & EndRow) = True Then
       Sheets(mySheetName).Select
       Range("A1").EntireRow.Select
       Selection.Copy
       Range("A" & EndRow + 3).Select
       Selection.Insert Shift:=xlDown
       
       For i = EndRow To 2 Step -1
           If Range("B" & i).Value = myValue Or Range("B" & i).Value = myValue1 Then
              Range("A" & i).EntireRow.Select
              Selection.Cut
              ZadnjaVrstica = Cells(Rows.Count, 2).End(xlUp).Row
              Range("A" & ZadnjaVrstica).Select
              Selection.Insert Shift:=xlUp
              Range("A" & i).EntireRow.Delete
           End If
       Next i
    End If

Funkcijo sem dobil nekje na netu. (funkcija in njena uporaba same po sebi delujeta). Zadnji del kode ( znotraj for stavka), kjer naj bi celice z vrednostjo myValue in myValue1 premaknilo na konec delovnega lista ne deluje pravilno. (nekaj sicer premika na konec lista, pa še polovica podatkev se nekje izgubi)

Hvala

[kljuka13]

Koda: Izberi vse

Sub premakniCelice()
Dim i
i = 1
Do While Not Range("B" & i).Value = ""
    i = i + 1
Loop
Range("B1:B" & i).Select
Selection.Cut Destination:=Range("B" & i+3 & ":B10")
Range("B1").Select
End Sub

Torej Vi ste si zamislili, da imate v B stolpcu neke podatke. Ti se morajo prokopirati 3 vrstice nižje od zadnje polne celice. Zgornji makro naredi to.

[PaPaDiZ]

Koda: Izberi vse

Sub premakniCelice()
Dim i
i = 1
Do While Not Range("B" & i).Value = ""
    i = i + 1
Loop
Range("B1:B" & i).Select
Selection.Cut Destination:=Range("B" & i+3 & ":B10")
Range("B1").Select
End Sub

Torej Vi ste si zamislili, da imate v B stolpcu neke podatke. Ti se morajo prokopirati 3 vrstice nižje od zadnje polne celice. Zgornji makro naredi to.

Nekaj podobnega. Jaz sem si zamislil, da bi na podlagi določene vrednosti v stolpcu B (v mojem primeru vrednosti "Vm" in "De") "odrezal" (cut) ali kopiral (sploh ni važno) celotno vrstico in jo premaknil tri vrstice nižje od zadnje uporabljene ter nato to vrednost na vrhu skupaj z vrstico izbrisal.
Upam da sem bil dovolj razumjiv.

[admin]

Spodaj prilagam kodo, ki dela to kar želite in na način, kot želite, v vaši kodi pa je preveč napak, da bi jo šel popravljat :

Koda: Izberi vse

Function AliJeVrednostVSeznamu(Seznam, vrednost) As Boolean
  AliJeVrednostVSeznamu = True
  
  Dim i
  For i = LBound(Seznam) To UBound(Seznam)
    If (UCase(Seznam(i)) = UCase(vrednost)) Then Exit Function
  Next
  AliJeVrednostVSeznamu = False
End Function

Sub PremakniVrstice()
  Dim iskaneVrednosti
  iskaneVrednosti = Array("Vm", "De")
  
  Dim ZadnjaVrstica
  ZadnjaVrstica = Range("B65536").End(xlUp).Row
  
  Dim i
  i = ZadnjaVrstica
  While (i > 0)
    If AliJeVrednostVSeznamu(iskaneVrednosti, Cells(i, 2).Value) Then
      Range("A" & i).EntireRow.Cut
      Range("A" & ZadnjaVrstica + 3).Select
      Selection.Insert Shift:=xlUp
      'Range("A" & i).EntireRow.Delete
    Else
      i = i - 1
    End If
  Wend
End Sub

[PaPaDiZ]

Matjaž, najlepša hvala. Točno to sem hotel. Če vam ne vzame preveč časa, a mi lahko prosim razložite kaj je bilo narobe v moji kodi.

Hvala še enkrat.

[admin]

Nimam časa (volje) iskreno povedano... Da ugotovite napake v kodi jo izvajajte korak po korak in poglete, kje se ne zgodi tisto, kar ste pričakovali, da bi se moralo zgoditi.