неправельная работа

Старая форма входа

Страница 1 из 1 1
Модератор форума: китин, _Boroda_

неправельная работа (макрос)

неправельная работа

рома

Дата: Вторник, 30.10.2012, 16:10 | Сообщение № 1

Группа: Гости

имеется вот такой вот макрос для разноса дат почему то стал пропускать некоторые даты... после следующего запуска он еще несколько дат перенесет и так несколько раз и может остановится на некоторых датах... сам недавно начал писать не могу понять в чем может быть причина

qw = 2050 ' количество прогоняемых строк
For i = 1 To qw
Dim pr As String
If IsDate(Sheets("1").Cells(i, 1).Value) Then 'ищем строку с датой

w2 = Cells(i, 1) '
q = DateDiff("d", Now, w2) ' вычисляем количество дней
pr = "'" & Cells(i, 10).Value ' ставим ' стоб сохранять числа из 20 знаков

' сроком до 30 дней
If q <= 30 Then
For e = 1 To qw
If Trim(Sheets("1").Cells(e, 1)) = " сроком до 30 дней" Then
e1 = e
For e2 = 1 To qw
If Trim(Sheets("1").Cells(e2, 1)) = " сроком 31-60 дней" Then
If e1 < i And i < e2 Then 'смотрим в том ли промежутке лежит
GoTo noob 'ничего не делаем
Else ' вставляем в нужный
Rows(i).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For e3 = e1 + 1 To e2
If Sheets("1").Cells(e3, 1) <> "" Then
w3 = Sheets("1").Cells(e3, 1)
qqw = DateDiff("d", Now, w3)
If q < qqw Then

Rows(i).Select
Selection.Cut
Rows(e3).Select
Selection.Insert Shift:=xlDown

Cells(e3, 10).Value = pr ' контрольное для 20 знаков

GoTo noob
End If
Else

Rows(i).Select
Selection.Cut
Rows(e3).Select
Selection.Insert Shift:=xlDown

GoTo noob
End If
Next
GoTo noob
End If
End If
Next
End If
Next
End If
дальше по аналогии

Ответить

Сообщениеимеется вот такой вот макрос для разноса дат почему то стал пропускать некоторые даты... после следующего запуска он еще несколько дат перенесет и так несколько раз и может остановится на некоторых датах... сам недавно начал писать не могу понять в чем может быть причина

qw = 2050 ' количество прогоняемых строк
For i = 1 To qw
Dim pr As String
If IsDate(Sheets("1").Cells(i, 1).Value) Then 'ищем строку с датой

w2 = Cells(i, 1) '
q = DateDiff("d", Now, w2) ' вычисляем количество дней
pr = "'" & Cells(i, 10).Value ' ставим ' стоб сохранять числа из 20 знаков

' сроком до 30 дней
If q <= 30 Then
For e = 1 To qw
If Trim(Sheets("1").Cells(e, 1)) = " сроком до 30 дней" Then
e1 = e
For e2 = 1 To qw
If Trim(Sheets("1").Cells(e2, 1)) = " сроком 31-60 дней" Then
If e1 < i And i < e2 Then 'смотрим в том ли промежутке лежит
GoTo noob 'ничего не делаем
Else ' вставляем в нужный
Rows(i).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
.PatternTintAndShade = 0
End With
For e3 = e1 + 1 To e2
If Sheets("1").Cells(e3, 1) <> "" Then
w3 = Sheets("1").Cells(e3, 1)
qqw = DateDiff("d", Now, w3)
If q < qqw Then

Rows(i).Select
Selection.Cut
Rows(e3).Select
Selection.Insert Shift:=xlDown

Cells(e3, 10).Value = pr ' контрольное для 20 знаков

GoTo noob
End If
Else

Rows(i).Select
Selection.Cut
Rows(e3).Select
Selection.Insert Shift:=xlDown

GoTo noob
End If
Next
GoTo noob
End If
End If
Next
End If
Next
End If
дальше по аналогии

Автор - рома
Дата добавления - 30.10.2012 в 16:10

Alex_ST

Дата: Вторник, 30.10.2012, 16:15 | Сообщение № 2

Группа: Друзья

Ранг: Участник клуба

Сообщений: 3213

Репутация: 609 ±

Замечаний: 0% ±

2003

рома,
Вы, что в серьёз думаете, что Ваш текст без знаков препинания и заглавных букв и код без начал и концов процедур, да ещё к тому же не оформленный тэгами {code} для читабельности кто-то ринется разбирать и анализировать?

С уважением,
Алексей
MS Excel 2003 - the best!!!

Сообщение отредактировал Alex_ST - Вторник, 30.10.2012, 16:16

Ответить

Формуляр

Дата: Вторник, 30.10.2012, 16:50 | Сообщение № 3

Группа: Друзья

Ранг: Ветеран

Сообщений: 832

Репутация: 255 ±

Замечаний: 0% ±

Excel 2003, 2013

Quote (Alex_ST)

рома, Вы, что в серьёз думаете, что Ваш текст без знаков препинания и заглавных букв и код без начал и концов процедур, да ещё к тому же не оформленный тэгами {code} для читабельности кто-то ринется разбирать и анализировать?

И без примера исходных данных- тоже не станет. angry

Excel 2003 EN, 2013 EN

Ответить

рома

Дата: Вторник, 30.10.2012, 17:33 | Сообщение № 4

Группа: Гости

Code

Sub sortirovka2()
Cells.Select
     With Selection.Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
         .PatternTintAndShade = 0
     End With

qw = 2050 'число строк
For i = 1 To qw
Dim pr As String
If IsDate(Sheets("1").Cells(i, 1).Value) Then 'ищем строку с датой

w2 = Cells(i, 1) '
q = DateDiff("d", Now, w2) ' количество дней до
pr = "'" & Cells(i, 10).Value ' контроль 20 знаков
'до 30 дней
    If q <= 30 Then
             For e = 1 To qw
                 If Trim(Sheets("1").Cells(e, 1)) = "до 30 дней" Then
                    e1 = e
                    For e2 = 1 To qw
                     If Trim(Sheets("").Cells(e2, 1)) = "31-60 дней" Then
                     If e1 < i And i < e2 Then   'промежуток блока
                      GoTo noob 'ничего не делаем
                     Else ' переносим
                           Rows(i).Select
                             With Selection.Interior
                    .Pattern = xlSolid
                    .PatternColorIndex = xlAutomatic
                    .ThemeColor = xlThemeColorDark2
                    .TintAndShade = 0
                    .PatternTintAndShade = 0
                    End With
                        For e3 = e1 + 1 To e2
                    If Sheets("1").Cells(e3, 1) <> "" Then
                    w3 = Sheets("1").Cells(e3, 1)
                    qqw = DateDiff("d", Now, w3)
                    If q < qqw Then
                    Rows(i).Select
                    Selection.Cut
                    Rows(e3).Select
                    Selection.Insert Shift:=xlDown
                    Cells(e3, 10).Value = pr 'контроль 20 знаков
                    GoTo noob
                    End If
                    Else
                    Rows(i).Select
                    Selection.Cut
                    Rows(e3).Select
                    Selection.Insert Shift:=xlDown
                    Cells(e3, 10).Value = pr ' контроль 20 знаков
                    GoTo noob
                    End If
                         Next
                         GoTo noob
                      End If
                      End If
                     Next
                 End If
             Next
     End If

дальше повторяются блоки тока срок разный

Code

End If
End If
noob:

Next

End Sub

на вход имеем

09.11.12
30.10.12
01.11.12
07.11.12
08.11.12
21.10.12
22.11.12
22.11.12
22.10.15
26.11.12
27.12.12
27.12.14
27.11.12
28.11.12
29.11.12
29.11.13

Code

дальше повторяются блоки тока срок разный

Code

End If
End If
noob:

Next

End Sub

на вход имеем

09.11.12
30.10.12
01.11.12
07.11.12
08.11.12
21.10.12
22.11.12
22.11.12
22.10.15
26.11.12
27.12.12
27.12.14
27.11.12
28.11.12
29.11.12
29.11.13рома

Ответить

Сообщение

Code

дальше повторяются блоки тока срок разный

Code

End If
End If
noob:

Next

End Sub

на вход имеем

09.11.12
30.10.12
01.11.12
07.11.12
08.11.12
21.10.12
22.11.12
22.11.12
22.10.15
26.11.12
27.12.12
27.12.14
27.11.12
28.11.12
29.11.12
29.11.13

Автор - рома
Дата добавления - 30.10.2012 в 17:33

Формуляр

Дата: Вторник, 30.10.2012, 17:40 | Сообщение № 5

Группа: Друзья

Ранг: Ветеран

Сообщений: 832

Репутация: 255 ±

Замечаний: 0% ±

Excel 2003, 2013

рома,
почему не прикрепить просто файл?
Откуда мне знать, что там на листе Sheets("1") и, тем более, Sheets("") wacko