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
Zadnjič spremenil PaPaDiZ, dne Ne Feb 10, 2008 8:14 pm, skupaj popravljeno 1 krat.
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
Č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?
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)
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.
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.
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
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.