Добрый день всем. Помогите разобраться с макросом. Макрос копирует данные из файла "Откуда копируем" в файл "Куда вставляем", причем если он не находит числовой эквивалент ИНН в столбце N файла "Куда вставляем", то вставляет просто данные (столбцы B-D,E,F,G-AM) вниз таблицы в соответствующие (по имени) столбцы файла "Куда вставляем", а вот если находит ИНН, то вставляет только столбцы F и G-AM в соответствующую строку. Собственно сам код с функцией перевода ИНН в число, в файле "Куда вставляем" вместо этого использована функция "Getnumbers" надстройки Plex
| Код |
|---|
Function Extract_Number_from_Text(Phrase As String) As Double
Dim Length_of_String As Integer
Dim Current_Pos As Integer
Dim Temp As String
Length_of_String = Len(Phrase)
Temp = ""
For Current_Pos = 1 To Length_of_String
If (Mid(Phrase, Current_Pos, 1) = "-") Then
Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (Mid(Phrase, Current_Pos, 1) = ".") Then
Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
If (IsNumeric(Mid(Phrase, Current_Pos, 1))) = True Then
Temp = Temp & Mid(Phrase, Current_Pos, 1)
End If
Next Current_Pos
If Len(Temp) = 0 Then
Extract_Number_from_Text = 0
Else
Extract_Number_from_Text = CDbl(Temp)
End If
End Function
Sub Копирование2()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim Lastrow&, Lastrow1&, Ws1, Ws2 As Worksheet, i%, n As Variant
Set Ws1 = ThisWorkbook.Worksheets("Список")
Ws1.Calculate
Set Ws2 = Workbooks.Open("C:\Users\Антон\Desktop\Куда вставляем.xlsm").Worksheets("Отработка")
Lastrow = Ws1.Range("D100000").End(xlUp).Row
Lastrow1 = WorksheetFunction.CountIf(Ws2.Range("C:C"), "<>")
For i = 4 To Lastrow
n = Application.Match(Extract_Number_from_Text(Ws1.Range("D" & i)), Ws2.Range("N:N"), 0)
If IsError(n) = True Then
Ws1.Range("B" & i & ":" & "D" & i).Copy
Ws2.Range("B" & Lastrow1 + 1).PasteSpecial Paste:=xlPasteValues
Ws1.Range("E" & i & ":" & "E" & i).Copy
Ws2.Range("L" & Lastrow1 + 1).PasteSpecial Paste:=xlPasteValues
Ws1.Range("F" & i & ":" & "F" & i).Copy
Ws2.Range("P" & Lastrow1 + 1).PasteSpecial Paste:=xlPasteValues
Ws1.Range("G" & i & ":" & "AM" & i).Copy
Ws2.Range("R" & Lastrow1 + 1).PasteSpecial Paste:=xlPasteValues
Else
Ws1.Range("F" & i).Copy
Ws2.Range("P" & n).PasteSpecial Paste:=xlPasteValues
Ws1.Range("G" & i & ":" & "AM" & i).Copy
Ws2.Range("R" & n).PasteSpecial Paste:=xlPasteValues
End If
Next
Ws2.Activate
Range("A2").Select
Selection.AutoFill Destination:=Range("A2:A" & Lastrow1), Type:=xlFillDefault
Range("I2").Select
Selection.AutoFill Destination:=Range("I2:I" & Lastrow1), Type:=xlFillDefault
Range("M2").Select
Selection.AutoFill Destination:=Range("M2:M" & Lastrow1), Type:=xlFillDefault
Range("N2").Select
Selection.AutoFill Destination:=Range("N2:N" & Lastrow1), Type:=xlFillDefault
Range("Q2").Select
Selection.AutoFill Destination:=Range("Q2:Q" & Lastrow1), Type:=xlFillDefault
Ws2.Calculate
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
|
Изменено: - 31.07.2021 13:28:50
