스프레드 시트에서 행 추출 및 조건을 기반으로 여러 스프레드 시트에 넣기

Question

엑셀 파일이 많은 폴더를 반복하며 각 파일에 대해 각 행 (4 행부터 시작)을 반복하며 각 행에 어떤 값이 열 "d"에 있는지보고 해당 행을 열 "d"의 값이 무엇이든간에 이름이 지정된 특정 Excel 파일에 붙여 넣습니다. 파일이 없으면 행을 붙여 넣기 전에 먼저 파일을 만들어야합니다 (붙여 넣을 때 행 4에서 시작). 새로 작성된 파일의 파일 이름은 열 "d"에 있던 값이됩니다. 파일이 이미 작성된 경우, 복사중인 행은 해당 파일 (지정된 행의 열 d 값)에 추가됩니다. 희망적으로 이것은 의미가 있습니다.

이것은 내가 지금까지 가지고있는 몇 가지 코드입니다. 내 코드는 모든 파일을 반복하고 싶지 않습니다. Excel VBA에 익숙하지 않아 도움을 크게 받으실 수 있습니다! 대단히 감사드립니다 !!

Sub CopyRowsIntoAppSpreadsheet() 

Dim LastRow As Integer, i As Integer, erow As Integer 
Dim AppFileName As String 
Dim FilePath As String 
Dim MyFolder As String 
Dim MyFile As String 
Dim wbk As Workbook 

On Error Resume Next 

Application.ScreenUpdating = False 



With Application.FileDialog(msoFileDialogFolderPicker) 

.Title = "Please select a folder" 

.Show 

.AllowMultiSelect = False 


    If .SelectedItems.Count = 0 Then 'If no folder is selected, abort 

MsgBox "You did not select a folder" 

     Exit Sub 

    End If 


MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder 

End With 

MyFile = Dir(MyFolder) 'DIR gets the first file of the folder 

'Loop through all files in a folder until DIR cannot find anymore 

Do While MyFile <> “” 

    'Opens the file and assigns to the wbk variable for future use 

    Set wbk = Workbooks.Open(FileName:=MyFolder & MyFile) 

    'Replace the line below with the statements you would want your macro to perform 

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

For i = 4 To LastRow 

    Range("d" & i).Select 

    AppFileName = Selection.Value 

    Rows(i).Select 

    Selection.Copy 

    FilePath = "C:\Users\Gary\Desktop\Ex Folder\" & AppFileName & ".xlsx" 

     If Not Dir(FilePath, vbDirectory) = vbNullString Then 

      Workbooks.Open FileName:=FilePath 
      Worksheets("Sheet1").Select 
      erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row 

      ActiveSheet.Cells(erow, 1).Select 
      ActiveSheet.Paste 
      Cells.Select 
      Cells.EntireColumn.AutoFit 
      ActiveWorkbook.Save 
      ActiveWorkbook.Close 
      Application.CutCopyMode = False 

     Else 
      Dim wkb As Workbook 
      Set wkb = Workbooks.Add 
      Rows(4).Select 
      ActiveSheet.Paste 
      wkb.SaveAs FileName:=FilePath 
      Cells.Select 
      Cells.EntireColumn.AutoFit 
      ActiveWorkbook.Save 
      ActiveWorkbook.Close 
      Application.CutCopyMode = False 
     End If 

    Next i 

MyFile = Dir 'DIR gets the next file in the folder 

Loop 

Application.ScreenUpdating = True 

MsgBox "Macro has completed! Woot! Woot!" 

End Sub 

Answer 1

OK,이 시도 :

Option Explicit 
Sub CopyRowsIntoAppSpreadsheet() 
Dim LastRow As Integer, erow As Integer, Rowcounter As Long 
Dim AppFileName As String 
Dim FilePath As String 
Dim MyFolder As String 
Dim MyFile As String 
Dim Source As Workbook, shSource As workseet, Dest As Workbook, shDest As Worksheet 
On Error Resume Next 
Application.ScreenUpdating = False 
With Application.FileDialog(msoFileDialogFolderPicker) 
.Title = "Please select a folder" 
.Show 
.AllowMultiSelect = False 
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort 
    MsgBox "You did not select a folder" 
    Exit Sub 
End If 
MyFolder = .SelectedItems(1) & "\" 'Assign selected folder to MyFolder 
End With 
MyFile = Dir(MyFolder) 'DIR gets the first file of the folder 
'Loop through all files in a folder until DIR cannot find anymore 
Do Until MyFile = "" 
    DoEvents 
    Set Source = Workbooks.Open(Filename:=MyFolder & MyFile) 
    Set shSource = Source.Sheets(1) 
    LastRow = shSource.Range("A" & Rows.Count).End(xlUp).Row 
    For Rowcounter = 4 To LastRow 
     'get the name of the workbook to copy to 
     AppFileName = Source.Cells(Rowcounter, 4) 
     FilePath = "C:\Users\Gary\Desktop\Ex Folder\" & AppFileName & ".xlsx" 
     'and open it 
     If FileExists(FilePath) Then 
      Set Dest = Workbooks.Open(Filename:=FilePath) 
     Else 
      Set Dest = Workbooks.Add 
     End If 
     Set shDest = Dest.Sheets(1) 
     'get the bottom row of the destination sheet 
     erow = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Row 
     shSource.Cells(Rowcounter, 1).EntireRow.Copy Destination:=shDest.Cells(erow + 1, 1) 
     Dest.SaveAs Filename:=FilePath 
     Dest.Close 
    'continue with next row 
    Next Rowcounter 
    Source.Close 
    'repeat for next file 
    MyFile = Dir() 'DIR gets the next file in the folder 
Loop 
Application.ScreenUpdating = True 
MsgBox "Macro has completed! Woot! Woot!" 
End Sub 
Function FileExists(FilePath As String) As Boolean 
Dim FSO As Object 
Dim sFile As String 
Set FSO = CreateObject("Scripting.FileSystemObject") 
If Not FSO.FileExists(FilePath) Then 
    FileExists = False 
Else 
    FileExists = True 
End If 
End Function