copy based on NAMES instead of ID

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
Hi Everyone,
Below i have a code which copies based on cell values(Highlighted) but instead of cell values, can we copy through cell name (Cell names which would be only in "Column C")

Rich (BB code):
FolderName = Worksheets("copy").Cells(2, "K").Value & "\"
    If FolderName <> "\" Then
        FileName = Dir(FolderName & "*.xl*")
        If FileName <> "" Then
            Application.ScreenUpdating = False
            While FileName <> ""
                
                Set wbTarget = Workbooks.Open(FileName:=FolderName & FileName, UpdateLinks:=False, ReadOnly:=True)
                i = 1
                For Each cell In wbTarget.Sheets(1).Range("D4:D5,D8,F14:F19").Cells
                    arr(i) = cell.Value
                    i = i + 1
                Next cell
                
                With FBP
                    .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(, UBound(arr)).Value = arr
                End With
                
                wbTarget.Close False
                Set wbTarget = Nothing
                Erase arr
                FileName = Dir
            Wend
            Application.ScreenUpdating = True
Cell names would be : Id,Name,class,div,sub1,sub2,sub3,sub4,sub5

Regards,
Dhruva
 
Last edited:

Some videos you may like

Excel Facts

Move date out one month or year
Use =EDATE(A2,1) for one month later. Use EDATE(A2,12) for one year later.

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,499
Try replacing in above code with:
Code:
For Each cell In wbtarget.Sheets(1).Range("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
 

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
Try replacing in above code with:
Code:
For Each cell In wbtarget.Sheets(1).Range("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
Thanks for your reply but i think i have not provided complete details like,

I have my headers in column B (ID,Name,Class,Div,Sub1,Sub2,Sub3,Sub4,Sub5) based on that i need to copy the values which are in F column

Like Example

Column CColumn DColumn EColumn F
ID............1234
Name............Dhruv
................
Sub5..........98

<tbody>
</tbody>


Regards
Dhruva
 

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
I tried replacing with Post #1 code

Code:
For Each cell In wbTarget.Sheets(1).Range("ID", "Name", "Class", "Div", "Sub1", "Sub2", "Sub3", "Sub4", "Sub5")
        arr(i) = Cells(i, 6).Value
        i = i + 1
 Next cell
But it's throwing me an error Run-time Error '450': "Wrong number of arguments or invalid property assignment"

Regards,
Dhruva
 

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,499
Can you post your full code?
 

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
Can you post your full code?
Code:
Option Explicit


Sub LoopThroughFiles()
    Dim FolderName As Variant, FileName As Variant
    Dim wbTarget As Workbook
    Dim FBP As Worksheet
    Dim arr(1 To 9) As Variant
    Dim cell As Range
    Dim i As Integer
    
    FolderName = Worksheets("copy").Cells(2, "K").Value & "\"
    If FolderName <> "\" Then
        FileName = Dir(FolderName & "*.xl*")
        If FileName <> "" Then
            Application.ScreenUpdating = False
            While FileName <> ""
                
                Set wbTarget = Workbooks.Open(FileName:=FolderName & FileName, UpdateLinks:=False, ReadOnly:=True)
                i = 1
                For Each cell In wbTarget.Sheets(1).Range("ID", "Name", "Class", "Div", "Sub1", "Sub2", "Sub3", "Sub4", "Sub5")
                    arr(i) = Cells(i, 6).Value
                    i = i + 1
                Next cell
                
                With Worksheets("copy")
                    .Cells(.Cells(.Rows.Count, "A").End(xlUp).Row + 1, 1).Resize(, UBound(arr)).Value = arr
                End With
                
                wbTarget.Close False
                Set wbTarget = Nothing
                Erase arr
                FileName = Dir
            Wend
            Application.ScreenUpdating = True
        Else
            MsgBox ("No Excel Files Found")
            Exit Sub
        End If
    Else
        MsgBox ("Please add Path in 'K2'")
        Exit Sub
    End If
End Sub
 
Last edited:

JackDanIce

Well-known Member
Joined
Feb 3, 2010
Messages
9,499
[Untested] Replace all of the code with below and try:
Rich (BB code):
Sub LTF()

    Dim sFolder As String
    Dim sFile   As String
    
    With Sheets("copy").Cells(2, 11)
        If Len(.Value) > 0 Then
            sFolder = .Value & "\"
            sFile = Dir(sFolder & "*.xl*")
        End If
        
        If Len(sFile) * Len(sFile) = 0 Then
            sFile = "Path missing in cell: " & .Address & vbCrLf & vbCrLf
            sFile = sFile & "Or no Excel files found in folder!"
            MsgBox sFile, vbExclamation, "Source Data Error"
            End
        End If
    End With
            
    Application.ScreenUpdating = False
    
    While Len(sFile) > 0
        CopyData sFolder & sFile, Sheets("copy").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        sFile = Dir
    Wend
    
    Application.ScreenUpdating = True  
    
End Sub

Private Sub CopyData(ByRef sFile As String, ByRef r As Range)

    Dim a   As Variant: a = Array("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
    Dim LR  As Long
    Dim x   As Long
    
    With Workbooks.Open(sFile, False, True)
        With .Sheets(1)
            LR = .Cells(.Rows.Count, 2).End(xlUp).Row
            For x = LBound(a) To UBound(a)
                'Search column B for headers, return values from column F
                a(x) = .Cells(1, 2).Resize(LR).Find(what:=a(x), lookat:=xlWhole, searchorder:=xlByColumns).Offset(, 4).Value
            Next x
        End With
    End With
    ActiveWorkbook.Close
    r.Resize(,UBound(a)).Value = a
    
    Erase a
    
End Sub
 
Last edited:

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
[Untested] Replace all of the code with below and try:
Rich (BB code):
Sub LTF()

    Dim sFolder As String
    Dim sFile   As String
    
    With Sheets("copy").Cells(2, 11)
        If Len(.Value) > 0 Then
            sFolder = .Value & "\"
            sFile = Dir(sFolder & "*.xl*")
        End If
        
        If Len(sFile) * Len(sFile) = 0 Then
            sFile = "Path missing in cell: " & .Address & vbCrLf & vbCrLf
            sFile = sFile & "Or no Excel files found in folder!"
            MsgBox sFile, vbExclamation, "Source Data Error"
            End
        End If
    End With
            
    Application.ScreenUpdating = False
    
    While Len(sFile) > 0
        CopyData sFolder & sFile, Sheets("copy").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        sFile = Dir
    Wend
    
    Application.ScreenUpdating = True  
    
End Sub

Private Sub CopyData(ByRef sFile As String, ByRef r As Range)

    Dim a   As Variant: a = Array("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
    Dim LR  As Long
    Dim x   As Long
    
    With Workbooks.Open(sFile, False, True)
        With .Sheets(1)
            LR = .Cells(.Rows.Count, 2).End(xlUp).Row
            For x = LBound(a) To UBound(a)
                'Search column B for headers, return values from column F
                a(x) = .Cells(1, 2).Resize(LR).Find(what:=a(x), lookat:=xlWhole, searchorder:=xlByColumns).Offset(, 4).Value
            Next x
        End With
    End With
    ActiveWorkbook.Close
    r.Resize(,UBound(a)).Value = a
    
    Erase a
    
End Sub
Thanks @JackDanIce
but its throwing me an error Run-time Error:"Object Variable or With block variable not set"
in Highlighted row

Regards,
Dhruva
 
Last edited:

Joe4

MrExcel MVP, Junior Admin
Joined
Aug 1, 2002
Messages
52,156
Office Version
365
Platform
Windows
but its throwing me an error Run-time Error:"Object Variable or With block variable not set"
in Highlighted row
Note that you will get that error if it does not find the value that you are looking for. So you need to add error handling or something else to to handle or ignore that scenario, i.e.
Code:
On Error Resume Next
a(x) = .Cells(1, [COLOR=#0000cd][B]2[/B][/COLOR]).Resize(LR).Find(what:=a(x), lookat:=xlWhole, searchorder:=xlByColumns).Offset(, [COLOR=#006400][B]4[/B][/COLOR]).Value
On Error GoTo 0
 

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
266
That worked but why am i getting the output as

IDNameClass....Sub5
IDNameClass....Sub5
IDNameClass....Sub5
IDNameClass....Sub5

<tbody>
</tbody>

what ever the value which are in array list that only i am getting as output, what changes should i make

Regards,
Dhruva
 

Watch MrExcel Video

Forum statistics

Threads
1,089,971
Messages
5,411,581
Members
403,380
Latest member
ifog671

This Week's Hot Topics

Top