Блог

Главная - Вопросы по программированию - попытка скопировать ненулевые строки, а также создать шаблон отчета

попытка скопировать ненулевые строки, а также создать шаблон отчета

#excel #vba

Вопрос:

У меня есть два включения, которые я хочу включить в этот код.

Во-первых, нужно опустить нулевые значения баланса (в столбце F в TB New) строк из моего TB New и вставить строки в TB New, отличные от нуля, я просто изменю входной лист с TB New на TB New, отличный от нуля. Я думал просто повторить этот код, но изменить его на новые переменные и просто сделать значение ячейки <> 0, но я попробовал, и это не сработало:

     Dim xTb As Range
    Dim xTbCell As Range
    Dim F As Long
    Dim G As Long
    Dim H As Long
    F = Worksheets("TB New").UsedRange.Rows.Count
    G = Worksheets("TB New Non Zero").UsedRange.Rows.Count
    If G = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("TB New Non Zero").UsedRange) = 0 Then G = 0
    End If
    Set xTb = Worksheets("TB New").Range("F1:F" amp; F)
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("TB New Non Zero").UsedRange.Offset(1).Clear
    G = 0
    For H = 1 To xTb.Count
        If CStr(xTb(H).Value) <> 0 Then
            xTb(H).EntireRow.Copy Destination:=Worksheets("TB New Non Zero").Range("F" amp; G   1)
            G = G   1
        End If
    Next

Приведенный выше код печатает только все строки и пропускает некоторые строки внизу, что не то, что я хочу.

Во-вторых,создать цикл for,где LEFT(значение столбца A, 1) = 0, затем скопировать строки, которые являются таковыми, затем установить значение следующей строки в качестве расходов, а затем добавить 1 в строку, затем, где LEFT(значение столбца A, 1) = 1, затем скопировать строки, а затем так далее.

По сути, в настоящее время это:

 0575 Interest 20
1015 Purchases -50
1680 Repairs -10
2000 Bank 200
2400 Debtors 0
2475 Plant 200

Но я хочу, чтобы это было так

 Revenue
0575 Interest 20
Expenses
1015 Purchases -50
1680 Repairs -10
Current Assets
2000 Bank 200
2475 Plant 200

Есть какая-нибудь помощь по этому коду? Спасибо,

 Function getLastUsedRow(ws As Worksheet) As Long

    Dim lastUsedRow As Long: lastUsedRow = 1
    On Error Resume Next
        lastUsedRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    On Error GoTo 0
    
    getLastUsedRow = lastUsedRow

End Function
Function getLastUsedColumn(ws As Worksheet) As Long
    
    Dim lastUsedColumn As Long: lastUsedColumn = 1
    On Error Resume Next
        lastUsedColumn = ws.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
    On Error GoTo 0
    
    getLastUsedColumn = lastUsedColumn

End Function
Function checkIfWorksheetExists(wb As Workbook, wsName As String) As Boolean

    Dim i As Long
    Dim found As Boolean
    
    found = False
    
    For i = 1 To wb.Worksheets.Count
    
        If Trim(wb.Worksheets(i).Name) = Trim(wsName) Then
        
            found = True
            Exit For
        
        End If
    
    Next i
    
    checkIfWorksheetExists = found

End Function
Public Function inCollection(ByVal inputCollection As Collection, ByVal inputKey As Variant) As Boolean

    On Error Resume Next
    inputCollection.Item inputKey
    inCollection = (Err.Number = 0)
    Err.Clear

End Function
Sub CopyRowBasedOnCellValue()
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long
    A = Worksheets("SQL hl_balance").UsedRange.Rows.Count
    B = Worksheets("CY amounts").UsedRange.Rows.Count
    If B = 1 Then
    If Application.WorksheetFunction.CountA(Worksheets("CY amounts").UsedRange) = 0 Then B = 0
    End If
    Set xRg = Worksheets("SQL hl_balance").Range("A1:A" amp; A)
    On Error Resume Next
    Application.ScreenUpdating = False
    Worksheets("CY amounts").UsedRange.Offset(1).Clear
    B = 4
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = Worksheets("Client Details").Range("C19").Value Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("CY amounts").Range("A" amp; B   1)
            B = B   1
        End If
    Next
    
    If Not checkIfWorksheetExists(ThisWorkbook, "Index") Then
        MsgBox "Please create Index sheet, and run macro again!"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    
    Dim i As Long
    Dim j As Long
    Dim k As Long

    Dim wsInputData As Worksheet: Set wsInputData = Worksheets("TB New")
    Dim wsInputDataStartingRow As Long: wsInputDataStartingRow = wsInputData.Range("C1").End(xlDown).Row   1 ' Starting row !
    Dim wsInputDataEndingRow As Long: wsInputDataEndingRow = getLastUsedRow(wsInputData)   10 ' Ending row !
    
    Dim wsInputDataUsedRange As Range: Set wsInputDataUsedRange = wsInputData.Range("A" amp; CStr(wsInputDataStartingRow) amp; ":" amp; "D" amp; CStr(wsInputDataEndingRow))

    Dim wsIndex As Worksheet: Set wsIndex = ThisWorkbook.Worksheets("Index")
    Dim wsIndexStartingRow As Long: wsIndexStartingRow = 5
    Dim wsIndexEndingRow As Long: wsIndexEndingRow = getLastUsedRow(wsIndex)   10
    
    Dim wsIndexUsedRange As Range: Set wsIndexUsedRange = wsIndex.Range("A" amp; CStr(wsIndexStartingRow) amp; ":" amp; "H" amp; CStr(wsIndexEndingRow))
    
    Dim wsIndexSheetCollection As Collection: Set wsIndexSheetCollection = New Collection
    Dim wsIndexCellCollection As Collection: Set wsIndexCellCollection = New Collection
    Dim wsIndexCellCollection2 As Collection: Set wsIndexCellCollection2 = New Collection
    Dim wsIndexStatusCollection As Collection: Set wsIndexStatusCollection = New Collection

    For i = wsIndexStartingRow To wsIndexEndingRow

        If Trim(wsIndex.Range("A" amp; CStr(i)).Value2) <> "" And Trim(wsIndex.Range("E" amp; CStr(i)).Value2) <> "" Then

            If wsIndex.Range("E" amp; CStr(i)).Hyperlinks.Count > 0 Then
                
                If Not inCollection(wsIndexSheetCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                    wsIndexSheetCollection.Add Trim(wsIndex.Range("E" amp; CStr(i)).Hyperlinks.Item(1).SubAddress), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                    wsIndexCellCollection2.Add Trim(wsIndex.Range("E" amp; CStr(i)).Value2), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                End If
            
            Else
            
                If Not inCollection(wsIndexSheetCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                    wsIndexSheetCollection.Add Trim(wsIndex.Range("E" amp; CStr(i)).Value2), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                    wsIndexCellCollection2.Add Trim(wsIndex.Range("E" amp; CStr(i)).Value2), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                End If
            
            End If
            
        End If

        If Trim(wsIndex.Range("A" amp; CStr(i)).Value2) <> "" And Trim(wsIndex.Range("F" amp; CStr(i)).Value2) <> "" Then
            
            If Not inCollection(wsIndexCellCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                wsIndexCellCollection.Add Trim(wsIndex.Range("F" amp; CStr(i)).Value2), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
            End If
        
        End If

        If Trim(wsIndex.Range("A" amp; CStr(i)).Value2) <> "" And Trim(wsIndex.Range("H" amp; CStr(i)).Value2) <> "" Then
            
            If Not inCollection(wsIndexStatusCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                wsIndexStatusCollection.Add Trim(wsIndex.Range("H" amp; CStr(i)).Value2), Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
            End If
        
        End If
    
    Next i

    Call Unlock_Sheet
    wsIndexUsedRange.ClearContents
    wsIndexUsedRange.Cells.Font.Bold = False

    wsInputDataUsedRange.Copy
    wsIndex.Range("A" amp; CStr(wsIndexStartingRow)).PasteSpecial xlPasteValuesAndNumberFormats
    Application.CutCopyMode = False


    wsIndexEndingRow = getLastUsedRow(wsIndex)   100

    For i = wsIndexEndingRow To wsIndexStartingRow Step -1
    
        If Trim(wsIndex.Range("B" amp; CStr(i)).Value2) = "" Then
            wsIndex.Rows(CStr(i) amp; ":" amp; CStr(i)).Delete
        End If
        
    Next i

    wsIndexEndingRow = getLastUsedRow(wsIndex)   10

    For i = wsIndexStartingRow To wsIndexEndingRow

        If Trim(wsIndex.Range("A" amp; CStr(i)).Value2) <> "" Then
        
            If inCollection(wsIndexSheetCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then

                If InStr(1, wsIndexSheetCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2)), "!") <> 0 Then

                    wsIndex.Hyperlinks.Add Anchor:=wsIndex.Range("E" amp; CStr(i)), Address:="", SubAddress:=wsIndexSheetCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2)), TextToDisplay:="'" amp; Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                    wsIndex.Range("E" amp; CStr(i)).Value2 = "'" amp; wsIndexCellCollection2.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
                Else

                    If checkIfWorksheetExists(ThisWorkbook, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then

                        If inCollection(wsIndexCellCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                            wsIndex.Hyperlinks.Add Anchor:=wsIndex.Range("E" amp; CStr(i)), Address:="", SubAddress:=Trim(wsIndex.Range("A" amp; CStr(i)).Value2) amp; "!" amp; wsIndexCellCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2)), TextToDisplay:=Trim("'" amp; wsIndex.Range("A" amp; CStr(i)).Value2)
                            wsIndex.Range("E" amp; CStr(i)).Value2 = "'" amp; wsIndexCellCollection2.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
                        Else
                            wsIndex.Hyperlinks.Add Anchor:=wsIndex.Range("E" amp; CStr(i)), Address:="", SubAddress:=Trim(wsIndex.Range("A" amp; CStr(i)).Value2) amp; "!A1", TextToDisplay:="'" amp; Trim(wsIndex.Range("A" amp; CStr(i)).Value2)
                            wsIndex.Range("E" amp; CStr(i)).Value2 = "'" amp; wsIndexCellCollection2.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
                        End If
                    Else

                        wsIndex.Range("E" amp; CStr(i)).Value2 = wsIndexSheetCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
                        
                    End If
                End If
                
            End If

            If inCollection(wsIndexCellCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                wsIndex.Range("F" amp; CStr(i)).Value2 = wsIndexCellCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
            End If

            wsIndex.Range("G" amp; CStr(i)).Formula = "=IFERROR(IF(OR(C" amp; CStr(i) amp; " D" amp; CStr(i) amp; "=INDIRECT(""'""amp;E" amp; CStr(i) amp; "amp;""'""amp;""!""amp; F" amp; CStr(i) amp; "),D" amp; CStr(i) amp; "-C" amp; CStr(i) amp; "=INDIRECT(""'""amp;E" amp; CStr(i) amp; "amp;""'""amp;""!""amp; F" amp; CStr(i) amp; "),C" amp; CStr(i) amp; "-D" amp; CStr(i) amp; "=INDIRECT(""'""amp;E" amp; CStr(i) amp; "amp;""'""amp;""!""amp; F" amp; CStr(i) amp; ")),1,0),"""")"

            If inCollection(wsIndexStatusCollection, Trim(wsIndex.Range("A" amp; CStr(i)).Value2)) Then
                wsIndex.Range("H" amp; CStr(i)).Value2 = wsIndexStatusCollection.Item(Trim(wsIndex.Range("A" amp; CStr(i)).Value2))
            End If
        
        End If
    
    Next i

    Set wsIndexSheetCollection = Nothing
    Set wsIndexCellCollection = Nothing
    Set wsIndexStatusCollection = Nothing
    Set wsIndex = Nothing

Sheets("Index").Select
Range("A1").Select

    MsgBox "Done !", vbInformation
    
    Application.ScreenUpdating = True
End Sub```


  [1]: https://i.stack.imgur.com/H1jT6.png

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

1. В вашем первом примере что такое xRg ? Ты пользуешься Option Explicit ? Во-вторых, слишком много кода, чтобы публиковать его без объяснения того, что с ним не так. Что он делает/не делает такого, чего не должен/не должен делать ?

2. @TimWilliams Второй код почти действительно хорош. Он вставляет суммы в ТБ, новые для листа индекса. Мне просто нужен определенный формат, в котором в цикле for я хочу иметь следующее: Выручка 04-09 Номера счетов (в столбце А) Расходы 10-19 Номера счетов Оборотные активы 20-24 Номера Внеоборотные активы 25-29 и так далее

Метки: ,