Копирование данных VBA из одной рабочей книги против ссылки в другой - PullRequest
Новая
       7

Копирование данных VBA из одной рабочей книги против ссылки в другой

0 голосов
/ 12 сентября 2018

Я просматривал Интернет для ответа, но не могу найти, чтобы помочь. Я пытаюсь открыть рабочую книгу и скопировать данные с вкладки «Данные» (B2 - I2) в основную рабочую книгу на вкладке «Регистрация». Подвох в том, что мне нужно вставить данные в соответствующую ссылку. В книге, которую я открываю, ссылка находится в A2, а в существующей книге ссылка, которую нужно искать, находится в столбце A.

Мне удалось написать код, который вставляет данные в номер строки ссылки, но это бесполезно, поскольку это должно быть фактическое значение в столбце A, которое оно ищет и вставляет в.

Любые идеи будут с благодарностью, пожалуйста! 

Sub Import()
Dim WB2op As String, CurWB As Workbook, WB2 As Workbook, nextrow As Long
Dim Row As Long
Dim ws As Worksheet
Set ws = Worksheets("Register")
Set CurWB = ThisWorkbook
WB2op = Application.GetOpenFilename _
(Title:="Please choose File", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If WB2op = "False" Then
    MsgBox "No file selected.", vbExclamation
    Exit Sub
Else
Set WB2 = Workbooks.Open(WB2op)
With Sheets("Data")    'change name to suit
    .Visible = xlSheetVisible
    .Activate
    .Range("A1").Select
End With

If WB2.Sheets("Data").Range("A2") >= 0 Then
Row = WB2.Sheets("Data").Range("A2") + 1
End If

Application.ScreenUpdating = False
ws.Range("N" & Row).Value = WB2.Sheets("Data").Range("B2")
ws.Range("O" & Row).Value = WB2.Sheets("Data").Range("C2")
ws.Range("P" & Row).Value = WB2.Sheets("Data").Range("D2")
ws.Range("Q" & Row).Value = WB2.Sheets("Data").Range("E2")
ws.Range("R" & Row).Value = WB2.Sheets("Data").Range("F2")
ws.Range("S" & Row).Value = WB2.Sheets("Data").Range("G2")
ws.Range("T" & Row).Value = WB2.Sheets("Data").Range("H2")
ws.Range("U" & Row).Value = WB2.Sheets("Data").Range("I2")
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If

WB2.Close False
End Sub

1 Ответ

0 голосов
/ 12 сентября 2018

Мне удалось это, добавив опцию MATCH, как показано ниже: 

Sub Import()
Dim WB2op As String, CurWB As Workbook, WB2 As Workbook, nextrow As Long
Dim Row As Long
Dim ws As Worksheet
Set ws = Worksheets("Register")
Set CurWB = ThisWorkbook
WB2op = Application.GetOpenFilename _
(Title:="Please choose File", _
FileFilter:="Excel Files *.xlsx* (*.xlsx*),")
If WB2op = "False" Then
    MsgBox "No file selected.", vbExclamation
    Exit Sub
Else
Set WB2 = Workbooks.Open(WB2op)
With Sheets("Data")    'change name to suit
    .Visible = xlSheetVisible
    .Activate
    .Range("A1").Select
End With

If WB2.Sheets("Data").Range("A2") >= 0 Then
On Error Resume Next
Row = Application.WorksheetFunction.Match(WB2.Sheets("Data").Range("A2"), ws.Range("A:A"), 0)
On Error GoTo 0

End If

Application.ScreenUpdating = False
ws.Range("N" & Row).Value = WB2.Sheets("Data").Range("B2")
ws.Range("O" & Row).Value = WB2.Sheets("Data").Range("C2")
ws.Range("P" & Row).Value = WB2.Sheets("Data").Range("D2")
ws.Range("Q" & Row).Value = WB2.Sheets("Data").Range("E2")
ws.Range("R" & Row).Value = WB2.Sheets("Data").Range("F2")
ws.Range("S" & Row).Value = WB2.Sheets("Data").Range("G2")
ws.Range("T" & Row).Value = WB2.Sheets("Data").Range("H2")
ws.Range("U" & Row).Value = WB2.Sheets("Data").Range("I2")
Application.CutCopyMode = False
Application.ScreenUpdating = True
End If

WB2.Close False End Sub

...