범위 값에 비슷한 이름을 가진 열린 통합 문서에 값을 붙여 넣기위한 VBA 코드

Question

나는 아래에 언급 된 코드에서 막혔다. 매번 변경 될 워크 시트 X2에서 Range("C4:C" & LastRow)의 값을 얻으려고한다. 각 값을 열려있는 모든 통합 문서 이름과 비교하십시오. 일치하는 것이 발견되면 워크 시트 X1의 A 열에서 해당 값을 검색하고 모든 행을 복사하십시오.

최종 목표는 같은 값을 가진 열려있는 통합 문서에 이러한 행을 붙여 넣는 것입니다. 예를 들어, Range C4가 TW00이면 코드는 이름이 "TW00.xlsx"인 통합 문서를 검색하고 TW00.xlsx라는 워크 시트의 열 A에 TW00 값을 갖는 워크 시트 X1의 모든 행을 복사합니다.

Dim BookNames() 
ReDim BookNames(Windows.Count) 
n = 1 

For n = 1 To Windows.Count 
    BookNames(n) = Workbooks(n).Name 
    If Workbooks(n).Name = Workbooks("A.xlsx").Worksheets("X2").Range("C4:C" & LastRow).Value Then 
     Set Rng = Workbooks("A.xlsx").Worksheets("X1").Range("A2:A50000") 
     For Each c In Rng.Cells 
      If c.Value = Workbooks("A.xlsx").Worksheets("X2").Range("C4").Value Then 
       If Not CopyRng Is Nothing Then 
        Set CopyRng = Application.Union(CopyRng, 
        Workbooks("A.xlsx").Worksheets("X1").Rows(c)) 
       Else 
        Set CopyRng = Workbooks("A.xlsx").Worksheets("X1").Rows(c) 
       End If 
      End If 
     Next c 

     CopyRng.Copy 
     Workbooks(n).Activate 
     Worksheets.Add 
     ActiveSheet.Name = "X1" 
     ActiveSheet.Paste 

    End If 
Next n 

Answer 1

그 코드가 도움이됩니까?

Sub test() 
Dim lastRow As Long 
dim sheetName as string 
Dim sourceDataSheet As worksheet 
Dim sourceSheetsName as worksheet 
dim targetDataSheet as worksheet 
Dim wkb As Variant 

set sourceDataSheet = ActiveWorkbook.Worksheets("X2") 
set sourceSheetsName = ActiveWorkbook.Worksheets("X1") 

With sourceSheetsName 
    lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
    sheetName = .Cells(lastRow, "A") 
     For Each wkb In Application.Workbooks 
      If wkb.Name <> .Name And wkb.Name = sheetName Then 
       set targetDataSheet = wkb.Worksheets.Add 
       with sourceDataSheet 
        lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row 
        for i = 1 to lastRow 
         if .Cells(i, "A").Value = sheetName then 
          .Cells(i, "A").EntireRow.Copy 
          targetDataSheet.Cells(i, "A").PasteSpecial Paste:=xlPasteValues 
         end if 
        next i 
       end with 
      End If 
     Next wkb 
End With 
End Sub