Макрос Excel запускается до тех пор, пока значения не будут найдены

Question

Я записал макрос для нижеуказанного excel: -

Код макроса: -

Sub Macro4()
'
' Macro4 Macro
'
' Keyboard Shortcut: Ctrl+Shift+D
'
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "P"
    Range("B1").Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$C$13").AutoFilter Field:=3, Criteria1:="Credit"
    Range("B3").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=-RC[-1]"
    Range("B3").Select
    Selection.Copy
    Range("A3").Select
    Selection.End(xlDown).Select
    Range("B12").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Range("B11").Select
    ActiveSheet.Range("$A$1:$C$13").AutoFilter Field:=3, Criteria1:="Debit"
    Range("B2").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "=RC[-1]"
    Range("B2").Select
    Selection.Copy
    Range("A2").Select
    Selection.End(xlDown).Select
    Range("B13").Select
    Range(Selection, Selection.End(xlUp)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.End(xlUp).Select
    ActiveSheet.ShowAllData
    Columns("B:B").Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Range("B2").Select
    Application.CutCopyMode = False
    Columns("A:B").Select
    Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    Range("B1").Select
    Selection.AutoFilter
End Sub

Это дает результат: -

Когда я пытаюсь использовать тот же макрос в приведенном ниже Excel: -

Это дает следующий результат.

На самом деле, я не знаю, сколько там будет цен, так как можно редактировать мой макрос таким образом, чтобы он выделял весь диапазон до последней строки

Answer 1

Вы также можете использовать формулу для этого?

B2=IFERROR(IF(C2="credit",A2*(-1),(IF(C2="Debit"),A2,""),""),"") 

Тогда просто используйте условное форматирование для столбца, чтобы получить цвета. Если вы настаиваете на макросе, вы можете добавить поиск последней строки и l oop через все строки, чтобы проверить значение столбца C. Должно быть легко найти и скопировать из Google, есть много примеров.

Дважды проверьте формулу, я написал ее на моем продаваемом телефоне, но все должно быть в порядке

Answer 2

Пожалуйста, попробуйте этот код. Он использует другой подход.

Sub BookToLedger()

    Dim Rng As Range
    Dim Cell As Range
    Dim R As Long

    Application.ScreenUpdating = False

    With Worksheets("Sheet1")       ' change tab name to suit
        Set Rng = .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
        .Columns(2).Insert Shift:=xlToRight
        .Cells(1, 2).Value = "Amount"
    End With

    With Rng
        .NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
        .Copy Destination:=.Offset(0, 1)
        Set Rng = .Offset(0, 1)
    End With

    For Each Cell In Rng.Cells
        With Cell
            If Left(.Offset(0, 1).Value, 2) = "Cr" Then
                .Value = .Value * -1
            End If
        End With
    Next Cell
    Application.ScreenUpdating = True
End Sub

Код сначала устанавливает формат чисел в столбце A. Затем он вставляет копию столбца A, включая новый формат чисел, в новый столбец B. Наконец, он зацикливается через все записи в столбце B и делает кредитные значения отрицательными.

Answer 3

Мое предложение будет

Option Explicit

Sub InsColP()

    Dim rg As Range
    Dim wks As Worksheet
    Set wks = ActiveSheet

    Columns("B:B").Insert Shift:=xlToRight


    With wks
        .Cells(1, 2) = "p"
        Set rg = .Range(.Cells(2, 2), .Cells(lastRow(1), 2))
    End With

    With rg
        .FormulaR1C1 = "=IF(RC[1]=""Debit"",RC[-1],-RC[-1])"
        .NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
    End With

End Sub

Function lastRow(col As Long, Optional wks As Worksheet) As Long

    If wks Is Nothing Then
        Set wks = ActiveSheet
    End If

    lastRow = wks.Cells(wks.Rows.Count, col).End(xlUp).Row

End Function

Answer 4

Этот макрос будет работать в активном листе. Так что выберите лист перед запуском этого макроса. или добавьте первую строку, чтобы упомянуть лист.

Sub Macro4()
' Keyboard Shortcut: Ctrl+Shift+D
Range("A1").Select
Dim tblRng As Range, cl As Range

Columns("B:B").Insert Shift:=xlToRight
Range("B1").FormulaR1C1 = "P"

Set tblRng = Range("A2", Range("C" & Rows.Count).End(xlUp))

For Each cl In Range(tblRng.Cells(1, 2), tblRng.Cells(tblRng.Rows.Count, 2))
If cl.Offset(0, 1) = "Credit" Then cl = -cl.Offset(0, -1)
If cl.Offset(0, 1) = "Debit" Then cl = cl.Offset(0, -1)
Next

Range(tblRng.Cells(1, 1), tblRng.Cells(tblRng.Rows.Count, 2)).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "


End Sub