Как перебрать таблицы, чтобы добавить новую строку с формулами и форматированием - PullRequest
Новая
       4

Как перебрать таблицы, чтобы добавить новую строку с формулами и форматированием

0 голосов
/ 10 октября 2018

У меня есть серия защищенных рабочих листов, которые используются для сбора данных об оценке учеников.Они заблокированы, чтобы пользователи не могли удалять формулы или вызывать другие проблемы, поэтому мне нужно иметь возможность добавлять новые записи в электронную таблицу / базу данных, используя форму пользователя.

Я скомпилировал следующий код, используя советы из других вопросов, имои (растущие) знания VBA, однако мои знания все еще находятся в зачаточном состоянии!

Когда я пытаюсь запустить код, я получаю ошибку «Требуется объект» в строке .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Select, как указано.Я подумал, что определил и указал объект как Sh, используя строку With Sh - это не так?

Я включил комментарии в код, чтобы попытаться объяснить, чего я пытаюсь достичь,Кто-нибудь может пролить свет на то, что я делаю здесь неправильно, пожалуйста? 

Private Sub cmbAdd_Click()
Dim Sh As Variant
Dim l As Long

Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Application.ScreenUpdating = False
'ActiveSheet.Unprotect Password:="L1lyL1ly"


    ' IF THERE ARE MORE THAN 103 RECORDS, ADD A NEW ROW AND COPY FORMAT AND FORMULAE

    For Each Sh In Array("Pupil Data", "RWM", "Art", "Computing", "Design Technology", "Geography", "History_", "MFL", "Music", "PE", "RE", "Science", "Bookbands", "KS1 - TRP")

    ' Use the current worksheet
    With Sh

    ' !!!!!!!!!!!! THE ERROR OCCURS ON THE NEXT LINE !!!!!!!!!!!!!!!!

        .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Select    ' Find the last used row in the table
        If .Cells(.Rows.Count) < 103 Then GoTo Add_Record            ' If the row number is less than 103 go to the Add_Record section otherwise add a new row and copy all formats and formulae

        .Rows(Selection.Row).Insert Shift:=xlDown

        With .Cells(.Rows.Count, "A").End(xlUp)
            .EntireRow.Copy
            With .Offset(1, 0).EntireRow
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteFormulas
                On Error Resume Next
                .SpecialCells(xlCellTypeConstants).ClearContents
                On Error GoTo 0
            End With
        End With
    End With
Next Sh     ' Cycle through to the next worksheet in the array and repeat the 'add line' procedure

Add_Record:   ' COPY NEW CHILD FROM FORM TO SPREADSHEET

Dim LR As Long
    LR = Sheets("Pupil Data").Range("A" & Rows.Count).End(xlUp).Row

    Set c = Range("A" & LR + 1)

    With Me
        c.Value = .TextBox14.Value
        c.Offset(0, 1).Value = .TextBox1.Value
        c.Offset(0, 2).Value = .TextBox2.Value
        c.Offset(0, 3).Value = .TextBox3.Value
        c.Offset(0, 4).Value = .TextBox4.Value
        c.Offset(0, 5).Value = .TextBox24.Value
        c.Offset(0, 7).Value = .TextBox25.Value
        c.Offset(0, 8).Value = .TextBox26.Value
        c.Offset(0, 9).Value = .TextBox5.Value
        c.Offset(0, 11).Value = .TextBox27.Value
        c.Offset(0, 12).Value = .TextBox28.Value
        c.Offset(0, 13).Value = .TextBox29.Value
        c.Offset(0, 14).Value = .TextBox30.Value
        c.Offset(0, 15).Value = .TextBox34.Value
        c.Offset(0, 16).Value = .TextBox31.Value
        c.Offset(0, 17).Value = .TextBox32.Value
        c.Offset(0, 18).Value = .TextBox33.Value
        c.Offset(0, 21).Value = .TextBox35.Value
        Call ClearControls
    End With

' FILL EMPTY CHARACTERISTICS CELLS

Dim rCell   As Range, _
        rRng    As Range

    For Each rRng In ActiveSheet.[A4].Resize(ActiveSheet.UsedRange.Rows.Count - 2)
        If IsEmpty(rRng) Then GoTo NextRow
        For Each rCell In rRng.Offset(0, 7).Resize(1, 17)
            If IsEmpty(rCell) Then rCell.Value = "N"
        Next rCell
NextRow:
    Next rRng

' SORT DATA TO INCLUDE NEW CHILD

 Call ResortData

Application.ScreenUpdating = True
'ActiveSheet.Protect "L1lyL1ly", _                      'Remove the ' from the start of the line when password protected
    'AllowFiltering:=True, _
    'AllowSorting:=True, _
    'AllowFormattingColumns:=True, _
    'AllowFormattingRows:=True

End Sub

1 Ответ

0 голосов
/ 10 октября 2018

Как прокомментировал StoneGiant, вы на самом деле не просматриваете свои рабочие таблицы, вы также выбираете последнюю строку без предварительного выбора листа, что приводит к ошибке, я бы также рекомендовал не использовать вложенные операторы With, не толькоесли это может сбить с толку, это может на самом деле не работать, как задумано, я думаю, что пересмотренный код ниже поможет вам достичь того, что вы хотите: 

Private Sub cmbAdd_Click()
Dim Sh As Worksheet
Dim l As Long
Dim LastRow As Long
Dim LR As Long

Application.ScreenUpdating = False
    ' IF THERE ARE MORE THAN 103 RECORDS, ADD A NEW ROW AND COPY FORMAT AND FORMULAE

    For Each Sh In ThisWorkbook.Worksheets
        ' Use the current worksheet
        With Sh
            LastRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0)    ' Find the last used row in the table
            If LastRow < 103 Then GoTo Add_Record            ' If the row number is less than 103 go to the Add_Record section otherwise add a new row and copy all formats and formulae
            .Rows(LastRow).Insert Shift:=xlDown
            .Cells(.Rows.Count, "A").End(xlUp).EntireRow.Copy
            .Cells(.Rows.Count, "A").End(xlUp).EntireRow.Offset(1, 0).EntireRow.PasteSpecial xlPasteFormats
            .Cells(.Rows.Count, "A").End(xlUp).EntireRow.Offset(1, 0).EntireRow.ClearContents
            .Cells(.Rows.Count, "A").End(xlUp).EntireRow.Offset(1, 0).EntireRow.PasteSpecial xlPasteFormulas
        End With
    Next Sh     ' Cycle through to the next worksheet in the array and repeat the 'add line' procedure

Add_Record:       ' COPY NEW CHILD FROM FORM TO SPREADSHEET

    LR = Sheets("Pupil Data").Range("A" & Rows.Count).End(xlUp).Row

    Set c = Range("A" & LR + 1)

    With Me
        c.Value = .TextBox14.Value
        c.Offset(0, 1).Value = .TextBox1.Value
        c.Offset(0, 2).Value = .TextBox2.Value
        c.Offset(0, 3).Value = .TextBox3.Value
        c.Offset(0, 4).Value = .TextBox4.Value
        c.Offset(0, 5).Value = .TextBox24.Value
        c.Offset(0, 7).Value = .TextBox25.Value
        c.Offset(0, 8).Value = .TextBox26.Value
        c.Offset(0, 9).Value = .TextBox5.Value
        c.Offset(0, 11).Value = .TextBox27.Value
        c.Offset(0, 12).Value = .TextBox28.Value
        c.Offset(0, 13).Value = .TextBox29.Value
        c.Offset(0, 14).Value = .TextBox30.Value
        c.Offset(0, 15).Value = .TextBox34.Value
        c.Offset(0, 16).Value = .TextBox31.Value
        c.Offset(0, 17).Value = .TextBox32.Value
        c.Offset(0, 18).Value = .TextBox33.Value
        c.Offset(0, 21).Value = .TextBox35.Value
        Call ClearControls
    End With

' FILL EMPTY CHARACTERISTICS CELLS

Dim rCell As Range, rRng As Range

    For Each rRng In ActiveSheet.[A4].Resize(ActiveSheet.UsedRange.Rows.Count - 2)
        If IsEmpty(rRng) Then GoTo NextRow
        For Each rCell In rRng.Offset(0, 7).Resize(1, 17)
            If IsEmpty(rCell) Then rCell.Value = "N"
        Next rCell
NextRow:
    Next rRng

' SORT DATA TO INCLUDE NEW CHILD

 Call ResortData

Application.ScreenUpdating = True
End Sub
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.

Похожие темы

...