Builder.cz - Informacni server o programovani

Odběr fotomagazínu

Fotografický magazín "iZIN IDIF" každý týden ve Vašem e-mailu.
Co nového ve světě fotografie!

 

Zadejte Vaši e-mailovou adresu:

Kamarád fotí rád?

Přihlas ho k odběru fotomagazínu!

 

Zadejte e-mailovou adresu kamaráda:



kontrola scriptu

Seznam témat     Nová odpověď

Přihlásit se     Registrace     Zapomenuté heslo

Re: kontrola scriptu

Autor: Petr Kaiser

15:50:58 07.01.2010

Diky, za odpoved, pokusim se to takto projit, nevedel jsem ze to umi :-)

Citovat příspěvek

 

Re: kontrola scriptu

Autor: honyk

12:28:33 01.01.2010

> proste obcas hodnoty nezkopiruje

Vidim kopirovani v obou listech, ktere kopirovani mate na mysli?

Obecne muze byt zrada v uvodni podmince Do Until IsEmpty(ActiveCell), ktera proces ukonci predcasne, pokud se v tabulce nachazi prazdna bunka. Ale jinak tezko soudit bez konkretnich dat. Zameril bych se na rozdil souboru, ktere lze a ktere nelze zpracovat. A pak bych doporucil prozkoumat moznosti debugeru, kterym se da kod spoustet radek po radku a pozorovat, jak se to vetvi na definovanych podminkach...

Citovat příspěvek

 

kontrola scriptu

Autor: Petr Kaiser

15:44:02 30.12.2009

Dobry den,
pouzivam nasledujici script v ms excel, ale po pul roce vyuzivani proste obcas hodnoty nezkopiruje. Napadlo me zda tam nemam nejakou prasarnu:-) Mohl by jste ho nekdo zkontrolovat?
Predem Dekuji

[quote]
Kod na jednom listu:

Private Sub CommandButton1_Click()
Dim resitel As String
Dim vyreseno As String
Dim prazdnyRadek As Integer
Dim listResitele As Worksheet
Dim zakladniPapir As Worksheet
Set zakladniPapir = Worksheets("Seznam2009")
' Select first line of data.
Range("C2").Select
' Set search variable value.
' Set Do loop to stop at empty cell.
Application.ScreenUpdating = False
Do Until IsEmpty(ActiveCell)
'Check active cell for search value.
'If ActiveCell.Value = x Then
vyreseno = zakladniPapir.Cells(ActiveCell.Row, 1).Value
If vyreseno <> "ok" Then
resitel = zakladniPapir.Cells(ActiveCell.Row, 18).Value
zakladniPapir.Cells(ActiveCell.Row, 2).Value = zakladniPapir.Cells(ActiveCell.Row - 1, 2).Value + 1
If resitel = "" Then
MsgBox "Řešitel na řádku " & ActiveCell.Row & " není zadán."
Else
If Not SheetExists(resitel) Then
Worksheets("Predloha").Visible = True
ActiveWorkbook.Sheets("Predloha").Copy after:=ActiveWorkbook.Sheets("Predloha")
ActiveSheet.Name = resitel
Worksheets("Predloha").Visible = False
Worksheets("Seznam2009").Select
Else
Set listResitele = Worksheets(resitel)
prazdnyRadek = listResitele.Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
listResitele.Cells(prazdnyRadek, 3).Value = zakladniPapir.Cells(ActiveCell.Row, 3).Value
listResitele.Cells(prazdnyRadek, 2).Value = zakladniPapir.Cells(ActiveCell.Row, 4).Value
listResitele.Cells(prazdnyRadek, 16).Value = zakladniPapir.Cells(ActiveCell.Row, 5).Value
listResitele.Cells(prazdnyRadek, 17).Value = zakladniPapir.Cells(ActiveCell.Row, 6).Value
listResitele.Cells(prazdnyRadek, 20).Value = zakladniPapir.Cells(ActiveCell.Row, 7).Value
listResitele.Cells(prazdnyRadek, 18).Value = zakladniPapir.Cells(ActiveCell.Row, 8).Value
listResitele.Cells(prazdnyRadek, 19).Value = zakladniPapir.Cells(ActiveCell.Row, 9).Value
listResitele.Cells(prazdnyRadek, 21).Value = zakladniPapir.Cells(ActiveCell.Row, 10).Value
listResitele.Cells(prazdnyRadek, 4).Value = zakladniPapir.Cells(ActiveCell.Row, 11).Value
listResitele.Cells(prazdnyRadek, 22).Value = zakladniPapir.Cells(ActiveCell.Row, 13).Value
listResitele.Cells(prazdnyRadek, 23).Value = zakladniPapir.Cells(ActiveCell.Row, 14).Value
listResitele.Cells(prazdnyRadek, 24).Value = zakladniPapir.Cells(ActiveCell.Row, 15).Value
listResitele.Cells(prazdnyRadek, 9).Value = zakladniPapir.Cells(ActiveCell.Row, 17).Value
listResitele.Cells(prazdnyRadek, 25).Value = zakladniPapir.Cells(ActiveCell.Row, 18).Value
listResitele.Cells(prazdnyRadek, 11).Value = zakladniPapir.Cells(ActiveCell.Row, 19).Value
listResitele.Cells(prazdnyRadek, 12).Value = zakladniPapir.Cells(ActiveCell.Row, 20).Value
listResitele.Cells(prazdnyRadek, 13).Value = zakladniPapir.Cells(ActiveCell.Row, 21).Value
listResitele.Cells(prazdnyRadek, 1).Value = zakladniPapir.Cells(ActiveCell.Row, 2).Value
zakladniPapir.Cells(ActiveCell.Row, 1).Value = "ok"
End If
End If
End If
'End If
' Step down 1 row from present location.
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub

Function SheetExists(SheetName As String) As Boolean
' returns TRUE if the sheet exists in the active workbook
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function

[/quote]

[quote]
Kod na druhem listu:

Option Explicit

Private Sub Workbook_Open()
On Error Resume Next
ActiveSheet.ShowAllData
On Error GoTo 0
End Sub


Sub Uloz()
Dim id As String
Dim rFound As Range
Dim rSearch As Range
Dim sFirstAddress As String
Dim cell As Range
Dim zakladniPapir As Worksheet
Set zakladniPapir = Worksheets("Seznam2009")
Dim listResitele As Worksheet
Set listResitele = Worksheets(ActiveSheet.Name)
Range("B2").Select
Application.ScreenUpdating = False
Do Until IsEmpty(ActiveCell)
id = listResitele.Cells(ActiveCell.Row, 1).Value
Set rSearch = Intersect(zakladniPapir.UsedRange, zakladniPapir.Columns(2))
'Find the first occurance
Set rFound = rSearch.Find(what:=id, _
after:=rSearch.Cells(rSearch.Cells.Count), _
lookat:=xlWhole)
'If was found
If Not rFound Is Nothing Then
'Store the address in a variable
sFirstAddress = rFound.Address
'Start a loop
Do
'Color the row of the found cell
zakladniPapir.Cells(rFound.Row, 12).Value = listResitele.Cells(ActiveCell.Row, 5).Value
zakladniPapir.Cells(rFound.Row, 23).Value = listResitele.Cells(ActiveCell.Row, 6).Value
zakladniPapir.Cells(rFound.Row, 25).Value = listResitele.Cells(ActiveCell.Row, 7).Value
zakladniPapir.Cells(rFound.Row, 16).Value = listResitele.Cells(ActiveCell.Row, 10).Value
zakladniPapir.Cells(rFound.Row, 24).Value = listResitele.Cells(ActiveCell.Row, 14).Value
zakladniPapir.Cells(rFound.Row, 26).Value = listResitele.Cells(ActiveCell.Row, 26).Value
zakladniPapir.Cells(rFound.Row, 27).Value = listResitele.Cells(ActiveCell.Row, 27).Value
zakladniPapir.Cells(rFound.Row, 22).Value = listResitele.Cells(ActiveCell.Row, 15).Value
'Find the next cell
Set rFound = rSearch.FindNext(rFound)
'Stop when Find loops back to the first cell found
Loop Until rFound.Address = sFirstAddress
End If
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
End Sub

[/quote]

Citovat příspěvek

 

 

 

Přihlášení k mému účtu

Uživatelské jméno:

Heslo: