Поиск и замена с другого листа - PullRequest
Новая
       8

Поиск и замена с другого листа

0 голосов
/ 09 июля 2019

Я застрял в проблеме с кодом, другой пользователь помог мне с этим, что код должен делать, это искать в листе последнюю информацию, а затем заменить следующие пустые ячейки для информации из другого листа.Код работал, и я вообще не перемещал его, затем, когда я закончил проект, я попробовал его, и код не работал.R2 не обнаруживает последнюю пустую ячейку, вместо этого, когда у диапазона есть информация, он заменяет первую непустую ячейку, когда у него нет информации, он идет на 5 строк ниже.

Изображение 1 Это формат, в котором люди будутзаполните, пример ищет 346

Изображение 2 Тогда формат 346, куда он должен вставить информацию, выглядит следующим образом (в нем уже есть информация)

Изображение 3 Добавление информации должно закончиться так(добавление информации под старой информацией вместо ее переписывания)

enter image description here

Private Sub C1_Click()

Dim Partida As String
Dim Rng As Range, r1 As Range, r2 As Range, UPa As Range
Dim Respuesta As String

If Sheets("Materiales").Range("C4").Value <> "Blanco" Then

'------------------------> Color
Sheets("Color").Unprotect
    Partida = Worksheets("Materiales").Range("C3").Value

        If Trim(Partida) <> "" Then
            With Sheets("Color").Rows("6:6")
                Set Rng = .Find(What:=Partida, After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    Set r2 = Rng.Offset(4, -1).End(xlDown)
                    'If r2.Row > 19 Then
                     '   Set r2 = Rng.Offset(4, -1)
                    'Else
                        'Set r2 = r2.Offset(1)
                    'End If
                    For Each r1 In Worksheets("Materiales").Range("B7:B16")
                        If Len(r1) > 0 Then
                            r2.Resize(, 2).Value = r1.Resize(, 2).Value
                            Set r2 = r2.Offset(1)
                        End If
                    Next r1

Полный код: 

Private Sub C1_Click()

Dim Partida As String
Dim Rng As Range, r1 As Range, r2 As Range, UPa As Range
Dim Respuesta As String

If Sheets("Materiales").Range("C4").Value <> "Blanco" Then

'------------------------> Color
Sheets("Color").Unprotect
    Partida = Worksheets("Materiales").Range("C3").Value

        If Trim(Partida) <> "" Then
            With Sheets("Color").Rows("6:6")
                Set Rng = .Find(What:=Partida, After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    Set r2 = Rng.Offset(4, -1).End(xlDown)
                    'If r2.Row > 19 Then
                     '   Set r2 = Rng.Offset(4, -1)
                    'Else
                        'Set r2 = r2.Offset(1)
                    'End If
                    For Each r1 In Worksheets("Materiales").Range("B7:B16")
                        If Len(r1) > 0 Then
                            r2.Resize(, 2).Value = r1.Resize(, 2).Value
                            Set r2 = r2.Offset(1)
                        End If
                    Next r1
                Finalizar = MsgBox("Información Agregada", vbOKOnly)
                Sheets("Materiales").Range("C2:C4").Value = ""
                Sheets("Materiales").Range("B7:C16").Value = ""


                Else
                    Respuesta = MsgBox("No se encontró, desea agregar la partida: " & Worksheets("Materiales").Range("C3").Value, vbYesNo, "Partida no encontrada")
                    If Respuesta = vbYes Then
                        With Sheets("Color").Rows("5:5")
                            Set UPa = .Find(What:="", Lookat:=xlWhole)
                            UPaD = UPa.Column
                        End With

                        Sheets("Patrón").Range("A1:C39").Copy
                        With Sheets("Color")
                            .Cells(5, UPaD).PasteSpecial PASTE:=xlPasteColumnWidths
                            .Cells(5, UPaD).PasteSpecial PASTE:=xlPasteAll
                        End With

                        With Sheets("Color")
                            Llenado = UPaD + 1
                            .Cells(5, Llenado).Value = Sheets("Materiales").Range("C2").Value
                            .Cells(6, Llenado).Value = Sheets("Materiales").Range("C3").Value
                            .Cells(7, Llenado).Value = Sheets("Materiales").Range("C4").Value
                            .Cells(10, UPaD).Value = Sheets("Materiales").Range("B7").Value
                            .Cells(10, Llenado).Value = Sheets("Materiales").Range("C7").Value
                            .Cells(11, UPaD).Value = Sheets("Materiales").Range("B8").Value
                            .Cells(11, Llenado).Value = Sheets("Materiales").Range("C8").Value
                            .Cells(12, UPaD).Value = Sheets("Materiales").Range("B9").Value
                            .Cells(12, Llenado).Value = Sheets("Materiales").Range("C9").Value
                            .Cells(13, UPaD).Value = Sheets("Materiales").Range("B10").Value
                            .Cells(13, Llenado).Value = Sheets("Materiales").Range("C10").Value
                            .Cells(14, UPaD).Value = Sheets("Materiales").Range("B11").Value
                            .Cells(14, Llenado).Value = Sheets("Materiales").Range("C11").Value
                            .Cells(15, UPaD).Value = Sheets("Materiales").Range("B12").Value
                            .Cells(15, Llenado).Value = Sheets("Materiales").Range("C12").Value
                            .Cells(16, UPaD).Value = Sheets("Materiales").Range("B13").Value
                            .Cells(16, Llenado).Value = Sheets("Materiales").Range("C13").Value
                            .Cells(17, UPaD).Value = Sheets("Materiales").Range("B14").Value
                            .Cells(17, Llenado).Value = Sheets("Materiales").Range("C14").Value
                            .Cells(18, UPaD).Value = Sheets("Materiales").Range("B15").Value
                            .Cells(18, Llenado).Value = Sheets("Materiales").Range("C15").Value
                            .Cells(19, UPaD).Value = Sheets("Materiales").Range("B16").Value
                            .Cells(19, Llenado).Value = Sheets("Materiales").Range("C16").Value
                        End With
                        Finalizar = MsgBox("Información Agregada", vbOKOnly)
                        Sheets("Materiales").Range("C2:C4").Value = ""
                        Sheets("Materiales").Range("B7:C16").Value = ""
                        End If


                    If Respuesta = vbNo Then
                        Sheets("Materiales").Activate
                    End If


                End If
            End With
            Sheets("Color").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Else
        PartidaN = MsgBox("Agregar partida", vbCritical, "Error")

        End If
Else

'--------------------------> Blanco
Sheets("Blanco").Unprotect
Partida = Worksheets("Materiales").Range("C3").Value

        If Trim(Partida) <> "" Then
            With Sheets("Blanco").Rows("6:6")
                Set Rng = .Find(What:=Partida, After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    Set r2 = Rng.Offset(4, -1).End(xlDown)
                    If r2.Row > 19 Then
                        Set r2 = Rng.Offset(4, -1)
                    Else
                        Set r2 = r2.Offset(1)
                    End If
                    For Each r1 In Worksheets("Materiales").Range("B7:B16")
                        If Len(r1) > 0 Then
                            r2.Resize(, 2).Value = r1.Resize(, 2).Value
                            Set r2 = r2.Offset(1)
                        End If
                    Next r1
                Finalizar = MsgBox("Información Agregada", vbOKOnly)
                Sheets("Materiales").Range("C2:C4").Value = ""
                Sheets("Materiales").Range("B7:C16").Value = ""
                Else
                    Respuesta = MsgBox("No se encontró, desea agregar la partida: " & Worksheets("Materiales").Range("C3").Value, vbYesNo, "Partida no encontrada")
                    If Respuesta = vbYes Then
                        With Sheets("Blanco").Rows("5:5")
                            Set UPa = .Find(What:="", Lookat:=xlWhole)
                            UPaD = UPa.Column
                        End With

                        Sheets("Patrón").Range("A1:C39").Copy
                        With Sheets("Blanco")
                            .Cells(5, UPaD).PasteSpecial PASTE:=xlPasteColumnWidths
                            .Cells(5, UPaD).PasteSpecial PASTE:=xlPasteAll
                        End With

                        With Sheets("Blanco")
                            Llenado = UPaD + 1
                            .Cells(5, Llenado).Value = Sheets("Materiales").Range("C2").Value
                            .Cells(6, Llenado).Value = Sheets("Materiales").Range("C3").Value
                            .Cells(7, Llenado).Value = Sheets("Materiales").Range("C4").Value
                            .Cells(10, UPaD).Value = Sheets("Materiales").Range("B7").Value
                            .Cells(10, Llenado).Value = Sheets("Materiales").Range("C7").Value
                            .Cells(11, UPaD).Value = Sheets("Materiales").Range("B8").Value
                            .Cells(11, Llenado).Value = Sheets("Materiales").Range("C8").Value
                            .Cells(12, UPaD).Value = Sheets("Materiales").Range("B9").Value
                            .Cells(12, Llenado).Value = Sheets("Materiales").Range("C9").Value
                            .Cells(13, UPaD).Value = Sheets("Materiales").Range("B10").Value
                            .Cells(13, Llenado).Value = Sheets("Materiales").Range("C10").Value
                            .Cells(14, UPaD).Value = Sheets("Materiales").Range("B11").Value
                            .Cells(14, Llenado).Value = Sheets("Materiales").Range("C11").Value
                            .Cells(15, UPaD).Value = Sheets("Materiales").Range("B12").Value
                            .Cells(15, Llenado).Value = Sheets("Materiales").Range("C12").Value
                            .Cells(16, UPaD).Value = Sheets("Materiales").Range("B13").Value
                            .Cells(16, Llenado).Value = Sheets("Materiales").Range("C13").Value
                            .Cells(17, UPaD).Value = Sheets("Materiales").Range("B14").Value
                            .Cells(17, Llenado).Value = Sheets("Materiales").Range("C14").Value
                            .Cells(18, UPaD).Value = Sheets("Materiales").Range("B15").Value
                            .Cells(18, Llenado).Value = Sheets("Materiales").Range("C15").Value
                            .Cells(19, UPaD).Value = Sheets("Materiales").Range("B16").Value
                            .Cells(19, Llenado).Value = Sheets("Materiales").Range("C16").Value
                        End With
                        Finalizar = MsgBox("Información Agregada", vbOKOnly)
                        Sheets("Materiales").Range("C2:C4").Value = ""
                        Sheets("Materiales").Range("B7:C16").Value = ""
                    End If


                    If Respuesta = vbNo Then
                        Sheets("Materiales").Activate
                    End If


                End If
            End With
            Sheets("Blanco").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
        Else
        PartidaN = MsgBox("Agregar partida", vbCritical, "Error")

        End If

End If
End Sub

Нет ошибок Msgs tho

Ответы [ 2 ]

0 голосов
/ 09 июля 2019

Проблема казалась простой строкой @Cyrill заставил меня осознать, что, поскольку код не может обнаружить заголовки, только путем изменения начального диапазона от 4 до 3 он начинает обнаруживать заголовки и информацию ниже. Спасибо вам всем за помощь:) 

Private Sub C1_Click()

Dim Partida As String
Dim Rng As Range, r1 As Range, r2 As Range, UPa As Range
Dim Respuesta As String

If Sheets("Materiales").Range("C4").Value <> "Blanco" Then

'------------------------> Color
Sheets("Color").Unprotect
    Partida = Worksheets("Materiales").Range("C3").Value

        If Trim(Partida) <> "" Then
            With Sheets("Color").Rows("6:6")
                Set Rng = .Find(What:=Partida, After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
                If Not Rng Is Nothing Then
                    Set r2 = Rng.Offset(3, -1).End(xlDown)

                    If r2.Row > 19 Then
                        Set r2 = Rng.Offset(4, -1)
                    Else
                        Set r2 = r2.Offset(1)
                    End If
                    For Each r1 In Worksheets("Materiales").Range("B7:B16")
                        If Len(r1) > 0 Then
                            r2.Resize(, 2).Value = r1.Resize(, 2).Value
                            Set r2 = r2.Offset(1)
                        End If
                    Next r1
0 голосов
/ 09 июля 2019

Перемещение комментария в ответ, так как просмотр кода в комментариях ужасен. 

Set Rng = .Find(What:=Partida, After:=.Cells(.Cells.Count), LookIn:=xlValues, Lookat:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
Set MatHead = Rng.Offset(3,-1)
If MatHead.end(xldown).font.bold = true then
    lr = MatHead.Offset(1).Row + 1
Else
    lr = MatHead.End(xlDown).Row + 1
End if
Cells(lr,1).Value = MATERIALES 'fix
Cells(lr,2).Value = KILOS 'fix

Большая проблема здесь заключается в том, что если вы заполнили значения в строках с 10 по 19, у вас будет .end(xldown) всегда заканчиваться на строке 20, что является выделенным жирным шрифтом значением «Всего», что означает, что вы начнете перезаписывать значение строки 10 (нумерация строк на основе ваших изображений).

Возможно, вы захотите избежать этого, если это возможно.

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

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

...