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

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
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
354
Alex Blakenburg
A
G
  • Solved
Change Macro to import files from hyperlinks
2
Replies
12
Views
947
GarnesGambit
G
B
  • Question Question
Error message when copying and renaming a worksheet
2
Replies
13
Views
343
smozgur
smozgur
H
  • Question Question
Referencing a series name that contains data linked to a cell VBA
Replies
1
Views
58
Rijnsent
Rijnsent
D
  • Solved
How to include date range in my PDF export name
Replies
4
Views
91
druck21
D

Forum statistics

Threads
1,224,819
Messages
6,181,153
Members
453,021
Latest member
Justyna P

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