Как поэтапно сравнивать два значения столбца и копировать всю строку, если ячейки в этих столбцах соответствуют условию - PullRequest
Новая
       1

Как поэтапно сравнивать два значения столбца и копировать всю строку, если ячейки в этих столбцах соответствуют условию

0 голосов
/ 21 января 2019

Я пытаюсь сравнить два столбца в одной рабочей книге и на основе определенного условия скопировать строку, где это условие выполняется, в другую рабочую книгу.

Это для "базы данных", над которой я работаю. У меня есть мастер-лист, а затем несколько версий субмастеров, специально предназначенных для определенных лиц.

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

Public Sub Workbook_Open()

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim vrtSelectedItem As Variant

Set wb1 = Application.Workbooks.Open("C:\Users\myfolder\Desktop\Excel Master Test\ROLE BASED TRACKER DRAFT.xlsx")
Set ws1 = wb1.Worksheets("Master")

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Sheet1")

'~~> Specifies which resources info. you are retrieving
strSearch = "117"
ws2.Cells.Clear

'~~> Copying the header information and formatting.
ws1.Range("1:1").Copy
ws2.Range("1:1").PasteSpecial

With ws1

    '~~> Remove any filters
    .AutoFilterMode = False

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("L1:L" & lRow)
        .AutoFilter Field:=1, Criteria1:=strSearch
         Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    .AutoFilterMode = False

End With

'~~> Destination File

With ws2
    If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row + 1
    Else
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
    End If
    copyFrom.Copy .Rows(lRow)
End With

With ws2
        '~~> Remove any filters
    .AutoFilterMode = False

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("AD1:AD" & lRow)
        .AutoFilter Field:=1, Criteria1:=strSearch
        .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
    End With

    .AutoFilterMode = False

End With

With ws1

    '~~> Remove any filters
    .AutoFilterMode = False

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    With .Range("AD1:AD" & lRow)
        .AutoFilter Field:=1, Criteria1:=strSearch
         Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
    End With

    .AutoFilterMode = False

End With

'~~> Destination File

With ws2
    If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row + 1
    Else
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
    End If
    copyFrom.Copy .Rows(lRow)
End With

With ws2.Sort
    .SetRange Range("A2:A12000")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

wb1.Save
wb1.Close
wb2.Save

End Sub

Это код, который я пытаюсь заставить работать. Я получаю ошибку несоответствия типов в строках сравнения ячеек . '' If ws1.Range("AD1:AD" & lRow) <> ws1.Range("L1:L" & lRow) Then '' 

Public Sub Workbook_Open()

Dim wb1 As Workbook, wb2 As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet
Dim copyFrom As Range
Dim lRow As Long
Dim strSearch As String
Dim vrtSelectedItem As Variant

Set wb1 = Application.Workbooks.Open("C:\Users\myfolder\Desktop\Excel Master Test\ROLE BASED TRACKER DRAFT.xlsx")
Set ws1 = wb1.Worksheets("Master")

Set wb2 = ThisWorkbook
Set ws2 = wb2.Worksheets("Sheet1")

'~~> Specifies which resources info. you are retrieving
strSearch = "117"
ws2.Cells.Clear

'~~> Copying the header information and formatting.
ws1.Range("1:1").Copy
ws2.Range("1:1").PasteSpecial

With ws1

    '~~> Remove any filters
    .AutoFilterMode = False

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    If ws1.Range("AD1:AD" & lRow) <> ws1.Range("L1:L" & lRow) Then

        With .Range("AD1:AD" & lRow)
            .AutoFilter Field:=1, Criteria1:=strSearch
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        .AutoFilterMode = False

    End If

End With

'~~> Destination File

With ws2
    If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row + 1
    Else
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
    End If
    copyFrom.Copy .Rows(lRow)
End With

With ws1

    '~~> Remove any filters
    .AutoFilterMode = False

    lRow = .Range("A" & .Rows.Count).End(xlUp).Row

    If ws1.Range("AD1:AD" & lRow) = ws1.Range("L1:L" & lRow) Then

        With .Range("L1:L" & lRow)
            .AutoFilter Field:=1, Criteria1:=strSearch
            Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow
        End With

        .AutoFilterMode = False

    End If

End With

'~~> Destination File

With ws2
    If Application.WorksheetFunction.CountA(.Rows) <> 0 Then
        lRow = .Cells.Find(What:="*", _
                      After:=.Range("A1"), _
                      Lookat:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row + 1
    Else
        lRow = .Range("A" & Rows.Count).End(xlUp).Row
    End If
    copyFrom.Copy .Rows(lRow)
End With


With ws2.Sort
    .SetRange Range("A2:A12000")
    .Header = xlNo
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

wb1.Save
wb1.Close
' wb2.Save

End Sub

1 Ответ

0 голосов
/ 22 января 2019

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

См. Мой первый блок кода, о котором я говорю.Приветствия.

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

Нет похожих вопросов

...