Столбец должен содержать значение; если да, то смещение столбца к этому значению должно содержать другое значение - PullRequest
0 голосов
/ 29 апреля 2020

Я впервые пишу вопрос, поэтому, пожалуйста, извините, если мое сообщение сбивает с толку и / или требуется более подробная информация.

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

Sub entryRetrieve()
'entryRetrieve - Macro to retrieve data from a certain range in the 'data 
 sheet' based on values from the entry sheet

'Defined worksheets'
Dim dataWS As Worksheet: Set dataWS = Worksheets("DATA")
Dim entryWS As Worksheet: Set entryWS = Worksheets("Indtastningsark")

'Defined values which is chosen based on a drop down menu in the 'entry sheet' '
Dim Initials As String: Initials = entryWS.Range("Initialer").Value
Dim Month As Long: Month = entryWS.Range("Måned").Value

'Ranges where copied values from the retrieved data hopefully should be placed'
Dim Tasks As Range: Set Tasks = entryWS.Range("J15:L24")
Dim Percentages As Range: Set Percentages = entryWS.Range("L15:L24")

'Function to sort through data in 'dataWS' and find if values exists. If yes, copy the range offset to the rows'
'This basically isn't working :( '
For Each cell In dataWS.Range("B2:B" & Range("B" & Rows.Count).End(xlUp).Row)
    If cell.Value = Month Then
        If cell.Offset(0, -1).Value = Initials Then
            MsgBox "found"
            'Copy the following 11 rows'
            Else
            MsgBox "Initials not found"
        End If
    End If
Next

End Sub

Итак, я надеюсь, что в письменном виде это так; основываясь на заданных значениях «инициалы» и «месяц», функция находит его в - соответственно - столбце «A» и столбце «B». В строках, где эти два значения существуют (и совпадают), функция копирует значения, содержащиеся в столбцах «C», «D» и «E», и вставляет их в определенный диапазон «Задачи» на другом листе.

Изображение прилагается - зеленый - это значения «инициалы» и «месяц»; синий должен быть скопирован.

Изображение данных

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

Надеюсь, вы понимаете мой вопрос. Если нет, спросите:)

РЕДАКТИРОВАТЬ:

Решение было найдено благодаря Самуилу!

Хотя теперь я наткнулся на еще одну проблему, связанную с этим: возможность вместо этого удалить строки с содержащимися данными.

With dataWS
    For Each Cell In .Range("B2:B" & LastRow)
        If Cell.Value = Month Then
            If Cell.Offset(0, -1).Value = Initials Then
                 Dim answer As Integer
                 answer = MsgBox("Er du sikker på at du vil slette registreringen: " & Month & " for '" & Initials & "'" _
                            , vbQuestion + vbYesNo + vbDefaultButton2, "Slet indtastning")
                 deleteRange = .Range(.Cells(Cell.Row, Cell.Offset(0, 1).Column), .Cells(Cell.Offset(9, 0).Row, Cell.Offset(0, 3).Column)) 'Can also be written as Range("C" & Cell.Row, "E" & Cell.Row + 11)

                 If answer = vbYes Then
                     '*** THIS DOESNT WORK ;( ***'
                     .Rows(deleteRange).EntireRow.Delete 
                 End If
           End If
        End If
    Next
End With

Второе редактирование - я получил удаление Функция данных работает благодаря Сэмюэлю Агиану!

With dataWS
    For Each Cell In .Range("B2:B" & LastRow)
        If Cell.Value = Month Then
            If Cell.Offset(0, -1).Value = Initials Then
                Dim answer As Integer
                answer = MsgBox("Er du sikker på at du vil slette registreringen: '" & Format(Month, "[$-da-DK]mmmm") & "' for '" & Initials & "'" _
                                , vbQuestion + vbYesNo + vbDefaultButton2, "Slet indtastning")
                If answer = vbYes Then
                    .Range(.Cells(Cell.Row, Cell.Column), .Cells(Cell.Offset(11, 0).Row, Cell.Column)).EntireRow.Delete

                    MsgBox "Registrering slettet!"
                    Opgaver.ClearContents
                Else
                    Exit For
                Exit For
                End If
            End If
        End If
    Next
End With

1 Ответ

0 голосов
/ 29 апреля 2020

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

Чтобы кратко объяснить это; Я объявляю переменные для ваших значений для проверки, LastRow будет использоваться так же, как вы, но я предпочитаю это в переменной для удобства чтения. Оба листа одинаковы (но для моего тестирования я использовал Sheet2 и Sheet3) и, наконец, массив для вашего диапазона для «копирования» и несколько переменных диапазона для циклов и место назначения для «вставки».

Ради тестирования я присвоил заданные значения Month и Initials.

Я включил некоторые с утверждениями, опять же, чтобы помочь читаемости.

Ваш For Each...Loop был в порядке, как это было и дал ожидаемые результаты, когда я запустил его. Я подозреваю, что когда вы пытались это сделать, ваши значения могли не соответствовать вашим ожиданиям, так как я получал каждый MsgBox, когда ожидал (я также добавил в сообщение немного дополнительной информации для отладки).

Вместо Copy и Paste, которые не являются наиболее эффективными функциями для использования, я все oop пробегаю по каждой строке в столбце B, ища месяц в формате цифр c - ( Январь = 1, февраль = 2 и т. Д. c.) - и, если найден, следующий условный оператор ищет строку «SE» в столбце A.

Если месяц верен, но строка не соответствует, MsgBox "Initials not found on row: " & Cell.Row срабатывает, однако, если они совпадают, CopyRange присваиваются значения из диапазона C6:E17.

Затем создается Destination, начиная с верхней левой ячейки диапазона и затем динамически изменен, чтобы соответствовать значениям массива. Затем массив записывается в диапазон Destination.

Массив пересекает каждую строку, а затем переходит к следующей. Ниже приведен код примера скриншотов ввода и вывода.

Код

Sub CAJTest()

Dim Month As Long
Dim Initials As String
Dim LastRow As Long

Dim entryWS As Worksheet
Dim dataWS As Worksheet
Set entryWS = Sheet3 '<~~ assign your correct sheet here
Set dataWS = Sheet2  '<~~ assign your correct sheet here

Dim CopyRange As Variant 'To be used as an array for our values.
Dim Destination As Range
Dim Cell As Range
Dim Tasks As Range

Month = 6
Initials = "SE"
LastRow = dataWS.Range("B" & Rows.Count).End(xlUp).Row 'I prefer to assign the last row to a variable

With dataWS
    For Each Cell In .Range("B2:B" & LastRow) 'I feel this is more readable than the above to find the last row being in this statement
        If Cell.Value = Month Then
            If Cell.Offset(0, -1).Value = Initials Then
                MsgBox "found " & Month & " and " & Initials & " on row: " & Cell.Row
                'the next line creates an array CopyRange with dimensions 1 to 12, 1 to 3 and assigns the values to the array
                CopyRange = .Range(.Cells(Cell.Row, Cell.Offset(0, 1).Column), .Cells(Cell.Offset(11, 0).Row, Cell.Offset(0, 3).Column)) 'Can also be written as Range("C" & Cell.Row, "E" & Cell.Row + 11)
                With entryWS
                    Set Destination = .Range("J15") 'Define top left cell of our destination
                    Set Destination = Destination.Resize(UBound(CopyRange, 1), UBound(CopyRange, 2)) 'Resize it per the bounds of our array
                    Destination.Value = CopyRange 'write the array to our newly resized destination range
                End With
                Exit For
            Else
                MsgBox "Initials not found on row: " & Cell.Row
            End If
        End If
    Next
End With

End Sub

Снимки экрана

Значения в столбцах C, D и E представляют адрес ячейки. Screenshot of sample input data

Вывод, как и ожидалось, для адресата с измененным размером, начиная с J15 Output after running the code

Для удаления строк:

Рассмотрим этот код для простого удаления данных из ячеек ...

If answer = vbYes Then 
'Delete Cell.Row + the following 9 rows' 

.Range(.Cells(Cell.Row, Cell.Column), .Cells(Cell.Offset(9, 0).Row, Cell.Column)).ClearContents 
Exit For

Обратите внимание, что это не проверено, но правильный синтаксис. Этот оператор будет очищать только столбец, к которому относится ссылка Cell, но диапазон начинается с ячейки и простирается на +9 строк.

Затем вы можете l oop пройти через лист и удалить строки на основе пустых ячеек. Это довольно медленный способ сделать это, но он полезен, если у вас непоследовательные пробелы.

Примечание: `ClearContents удалит значения из формул и из диапазона ,


Если вы также хотите удалить строки, чтобы избежать пропусков в ваших данных, вы можете определить свой диапазон и использовать метод EntireRow.Delete ...

If answer = vbYes Then 
'Delete Cell.Row + the following 9 rows' 

.Range(.Cells(Cell.Row, Cell.Column), .Cells(Cell.Offset(9, 0).Row, Cell.Column)).EntireRow.ClearContents 
Exit For

Если у вас есть Возникли проблемы с этим методом, рассмотрите возможность добавления точки останова в этой строке ( F9 ) и затем запустите свой код. Когда в этой строке произойдет разрыв, проверьте правильность диапазона (введите ?.Range(.Cells(Cell.Row, Cell.Column), .Cells(Cell.Offset(9, 0).Row, Cell.Column)).Address в окне и нажмите Enter).

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