Блог

Главная - Вопросы по программированию - Проблема с для каждого цикла в Excel

Проблема с для каждого цикла в Excel

#excel #vba

#excel #vba

Вопрос:

Я опубликовал это в mrexcel, но не получил ответа. Вот почему я публикую здесь.

У меня возникли две проблемы с приведенным ниже кодом.

  1. Если диапазон содержит только одну строку, например, H12-K12 тогда он выполняется только для первой ячейки I12 , а затем останавливается. Но он должен выполняться до K15 .
  2. Если диапазон содержит несколько строк как H12-K15 , то он выполняется до I15 и после этого останавливается. Но он должен выполняться до K15 .

Что я делаю не так?

Данные…..

введите описание изображения здесь

Требуется вывод, как показано ниже. Требуемый вывод

 Option Explicit

Sub CreatPackingList()
    
'    On Error Resume Next
    
    Dim xTitleId As String
    xTitleId = "Input box--"
    
    Dim WorkRng As Range
    Set WorkRng = Application.Selection
    Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)
    
    Dim xNum As Integer
    xNum = Application.InputBox("Division num", xTitleId, Type:=1)
    
    Dim Rng As Range
    For Each Rng In WorkRng
        If Rng.Value > xNum Then
        
            Dim nThNumber As Double
            nThNumber = Rng.Value / xNum
            
            Dim nThNumberNoDecimil As Single
            nThNumberNoDecimil = nThNumber
            
            'to remove decimil data
            Dim nThNumberNoDecInt As Integer
            nThNumberNoDecInt = CInt(Fix(nThNumberNoDecimil))
            
            Dim totalValue As Integer
            totalValue = nThNumberNoDecInt * xNum
            
            Dim balanceValue As Integer
            balanceValue = Rng.Value - totalValue
            
            Rng.Value = xNum
            Rng.EntireRow.Copy
            
            Dim cUrrentCellCol As Integer
            cUrrentCellCol = Range(Rng.Offset(0, 0), Rng.Offset(0, 0)).Column
            Dim cUrrentCellRow As Integer
            cUrrentCellRow = Range(Rng.Offset(0, 0), Rng.Offset(0, 0)).Row
            
            'coPyRowNThTime
            '----------------------
            If balanceValue > 0 Then
                Dim coPyRowNThTime As Integer
                coPyRowNThTime = 2
                Range(Rng.Offset(1, 0), Rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                Range(Rng.Offset(1, 0), Rng.Offset(1, 0)).Value = balanceValue
                Range(Rng.Offset(2, 0), Rng.Offset(2, 0)).ClearContents
                'Ctn no at column T
                Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                Cells(cUrrentCellRow, 20).Offset(1, 0).Value = 1
                
                If cUrrentCellCol = 8 Then
                
                    Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                    Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                ElseIf cUrrentCellCol = 19 Then
                    Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                    Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                    
                Else
                    Dim leftColNumber As Integer
                    leftColNumber = cUrrentCellCol - 1
                    Dim rightColNumber As Integer
                    rightColNumber = cUrrentCellCol   1
                    
                    Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                    Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                    Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
                    Range(Cells(cUrrentCellRow, rightColNumber).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                    
                End If
                    'delete emptye row in H-S column, if qty is nothing
                If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 19).Offset(2, 0))) = 0 Then
                    Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 18).Offset(2, 0)).EntireRow.Delete
                End If
                    
            Else
                coPyRowNThTime = 1
                Range(Rng.Offset(1, 0), Rng.Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                Range(Rng.Offset(1, 0), Rng.Offset(1, 0)).ClearContents
                
                'Ctn no at column T
                Cells(cUrrentCellRow, 20).Value = nThNumberNoDecInt
                
                If cUrrentCellCol = 8 Then
                    Range(Cells(cUrrentCellRow, 9), Cells(cUrrentCellRow, 19)).ClearContents
                
                ElseIf cUrrentCellCol = 19 Then
                    Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 18)).ClearContents
                
                Else
                    leftColNumber = cUrrentCellCol - 1
                    rightColNumber = cUrrentCellCol   1
                    Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, leftColNumber)).ClearContents
                    Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents
                
                End If
                
                'delete emptye row in H-S column, if qty is nothing
                If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0))) = 0 Then
                    Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).EntireRow.Delete
                End If
                
            End If
        '---------------------
        End If
    Next

End Sub

Комментарии:

1. 1. Форматированный код очень полезен. 2. Какова цель On Error Resume Next , когда вы не улавливаете никаких ошибок и не возвращаете перехват ошибок в нормальное состояние. (Я отредактировал ваш код и удалил, поскольку для этого нет причин). 3. Ваши диапазоны не указаны. Предлагаю просмотреть ваш код и обновить. Посмотрите на RubberDuck или MZ-Tools, чтобы помочь с обновлениями.

2. Основная причина, по которой ваш код «останавливается», заключается в том, что на первой итерации цикла при обработке ячейки I12 строка Range(Cells(cUrrentCellRow, rightColNumber), Cells(cUrrentCellRow, 19)).ClearContents очищает ячейки J12:K12 . Поэтому, когда цикл For переходит к следующей итерации, Rng будет ссылаться на J12 и If Rng.Value > xNum Then будет False . Совсем не ясно, что вы пытаетесь здесь сделать, поэтому я не буду гадать о возможных исправлениях. Тем не менее, пара основ: избавьтесь от On Error Resumre Next и, поскольку вы вставляете строки, выполняйте цикл снизу вверх от вашего диапазона строк.

3. Даже после возобновления работы с ошибкой он действует одинаково. Вот мой файл с кодом. файл

4. @MehidyHassan конечно, это действует одинаково — вы не поняли остальную часть моего комментария?

5. для редакторов: удаление On Error Resume Next и правильный отступ стали бы частью хорошего ответа на вопрос, а не редактирования

Ответ №1:

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

 
Sub CreatPackingListReverse()
    Dim i As Long, rng As Range, t As String
    
    Dim xTitleId As String
    xTitleId = "Input box--"
    Set rng = Application.InputBox("Range", xTitleId, Type:=8)
      t = rng.Address
    
    Dim xNum As Integer
    xNum = Application.InputBox("Division num", xTitleId, Type:=1)
    
    For i = Range(t).Cells.Count To 1 Step -1

 If rng.Item(i).Value > xNum Then
        
            Dim nThNumber As Double
            nThNumber = rng.Item(i).Value / xNum
            
            Dim nThNumberNoDecimil As Single
            nThNumberNoDecimil = nThNumber
            
            'to remove decimil data
            Dim nThNumberNoDecInt As Integer
            nThNumberNoDecInt = CInt(Fix(nThNumberNoDecimil))
            
            Dim totalValue As Integer
            totalValue = nThNumberNoDecInt * xNum
            
            Dim balanceValue As Integer
            balanceValue = rng.Item(i).Value - totalValue
            
            rng.Item(i).Value = xNum
            rng.Item(i).EntireRow.Copy
            
            Dim cUrrentCellCol As Integer
            cUrrentCellCol = rng.Item(i).Column
            Dim cUrrentCellRow As Integer
            cUrrentCellRow = rng.Item(i).Row
            
            'coPyRowNThTime
            '----------------------


If balanceValue > 0 Then
                Dim coPyRowNThTime As Integer
                coPyRowNThTime = 2
                Range(rng.Item(i).Offset(1, 0), rng.Item(i).Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                rng.Item(i).Offset(2, 0).Value = balanceValue
                rng.Item(i).ClearContents
                'Ctn no at column T
                Cells(cUrrentCellRow, 20).Offset(1, 0).Value = nThNumberNoDecInt
                Cells(cUrrentCellRow, 20).Offset(2, 0).Value = 1
                
                If cUrrentCellCol = 8 Then
                
                    Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                    Range(Cells(cUrrentCellRow, 9).Offset(2, 0), Cells(cUrrentCellRow, 19).Offset(2, 0)).ClearContents

                ElseIf cUrrentCellCol = 19 Then
                     Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                     Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, 18).Offset(2, 0)).ClearContents
                    
                Else
                    Dim leftColNumber As Integer
                    leftColNumber = cUrrentCellCol - 1
                    Dim rightColNumber As Integer
                    rightColNumber = cUrrentCellCol   1
                    
                    Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                    Range(Cells(cUrrentCellRow, 8).Offset(2, 0), Cells(cUrrentCellRow, leftColNumber).Offset(2, 0)).ClearContents
                    
                    Range(Cells(cUrrentCellRow, rightColNumber).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                    Range(Cells(cUrrentCellRow, rightColNumber).Offset(2, 0), Cells(cUrrentCellRow, 19).Offset(2, 0)).ClearContents
                    
                End If
                    'delete emptye row in H-S column, if qty is nothing
                If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 19))) = 0 Then
                    'Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 19)).EntireRow.Delete
                    rng.Item(i).EntireRow.Delete
                End If
                    
            Else
                coPyRowNThTime = 1
                Range(rng.Item(i).Offset(1, 0), rng.Item(i).Offset(coPyRowNThTime, 0)).EntireRow.Insert Shift:=xlDown
                rng.Item(i).ClearContents
                
                'Ctn no at column T
                Cells(cUrrentCellRow, 20).Offset(1, 0).Value = nThNumberNoDecInt
                
                If cUrrentCellCol = 8 Then
                 Range(Cells(cUrrentCellRow, 9).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents

                ElseIf cUrrentCellCol = 19 Then
                Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, 18).Offset(1, 0)).ClearContents
                
                Else
                    leftColNumber = cUrrentCellCol - 1
                    rightColNumber = cUrrentCellCol   1
                Range(Cells(cUrrentCellRow, 8).Offset(1, 0), Cells(cUrrentCellRow, leftColNumber).Offset(1, 0)).ClearContents
                Range(Cells(cUrrentCellRow, rightColNumber).Offset(1, 0), Cells(cUrrentCellRow, 19).Offset(1, 0)).ClearContents
                End If
                
                'delete emptye row in H-S column, if qty is nothing
                If WorksheetFunction.CountA(Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 19))) = 0 Then
                    'Range(Cells(cUrrentCellRow, 8), Cells(cUrrentCellRow, 19)).EntireRow.Delete
                    rng.Item(i).EntireRow.Delete
                End If
                
            End If

'---------------------
Else
cUrrentCellRow = rng.Item(i).Row
rng.Item(i).Value = rng.Item(i).Value
Cells(cUrrentCellRow, 20).Value = 1
        End If
    Next i

End Sub