copy based on NAMES instead of ID

G

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

What do {} around a formula in the formula bar mean?
{Formula} means the formula was entered using Ctrl+Shift+Enter signifying an old-style array formula.
Sort by date Sort by votes
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
JackDanIce said:
Try replacing in above code with:
Code: 
For Each cell In wbtarget.Sheets(1).Range("ID", "Name", "class", "div", "sub1", "sub2", "sub3", "sub4", "sub5")
Click to expand...

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

[TABLE="width: 500"]
<tbody>[TR]
[TD]Column C[/TD]
[TD]Column D[/TD]
[TD]Column E[/TD]
[TD]Column F[/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]......[/TD]
[TD]......[/TD]
[TD]1234[/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD]......[/TD]
[TD]......[/TD]
[TD]Dhruv[/TD]
[/TR]
[TR]
[TD]...[/TD]
[TD]....[/TD]
[TD].....[/TD]
[TD]....[/TD]
[/TR]
[TR]
[TD]Sub5[/TD]
[TD].....[/TD]
[TD].....[/TD]
[TD]98[/TD]
[/TR]
</tbody>[/TABLE]


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
JackDanIce said:
Can you post your full code?
Click to expand...

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
JackDanIce said:
[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
Click to expand...

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
Click to expand...
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

[TABLE="width: 500"]
<tbody>[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Class[/TD]
[TD]....[/TD]
[TD]Sub5[/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Class[/TD]
[TD]....[/TD]
[TD]Sub5[/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Class[/TD]
[TD]....[/TD]
[TD]Sub5[/TD]
[/TR]
[TR]
[TD]ID[/TD]
[TD]Name[/TD]
[TD]Class[/TD]
[TD]....[/TD]
[TD]Sub5[/TD]
[/TR]
</tbody>[/TABLE]

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
You must log in or register to reply here.

Similar threads

J
  • Question Question
Append data to master file
Replies
6
Views
337
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
938
GarnesGambit
G
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
297
smozgur
smozgur
S
  • Solved
Transfer data from several workbooks to the main one
Replies
7
Views
654
eiloken
E
M
  • Question Question
Split Excel Workbook to separate .xlsx files for each unique value in Column A, also copy worksheet for Drop Down reference
Replies
9
Views
453
Alex Blakenburg
A

Forum statistics

Threads
1,223,886
Messages
6,175,196
Members
452,616
Latest member
intern444

Share this page

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