copy based on NAMES instead of ID

GirishDhruva

Active Member
Joined
Mar 26, 2019
Messages
308
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:

Excel Facts

Formula for Yesterday
Name Manager, New Name. Yesterday =TODAY()-1. OK. Then, use =YESTERDAY in any cell. Tomorrow could be =TODAY()+1.
Try replacing in above code with:
Code:
For Each cell In wbtarget.Sheets(1).Range("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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:
Upvote 0
[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:
Upvote 0
[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:
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,510
Messages
6,114,037
Members
448,543
Latest member
MartinLarkin

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top