[Excel/VBA ] How to Find and copy data(Mapped data) from another worksheet using VBA?

[prashantdixit]

Hi all,

I am new to Excel/VBA and would require your help.
I have stuck again somewhere and will be highly obliged if you can help me.

I have two worksheet
1. Import File Utility (Sheet A)
2. TeamCenterVsFileMapping (Sheet B)

In Sheet A there are five columns(File Path, File Type, Dataset Type, Dataset Name, Named Reference) and "Import" button. if user clicks on Import button and select any folder, then Filepath, Filetype, Dataset Name(i.e Filename) corresponding to all files are imported in the Sheet A's Cells. But i also need to import values corresponding to Dataset Type and Named Reference. These values are fetching from Sheet B i.e TeamCenterVsFileMapping.
There is a mapping of Filetype Vs Dataset Type Vs Named Reference in Sheet B just like:


FileType ---- DatasetType ---- NamedReference
------------------------------------------------
zip ---- zipAddress ---- MScompression
accdb ---- Access ---- MSAccess
jpeg ---- Image ---- Xyz
jpg ---- Image ---- XXX
pdf ---- Acrobat ---- YYY


No what i want for each filetype in Sheet A, it will search File Type in Sheet B and if it finds then copy the Dataset Type and Named Reference value from Sheet B to Sheet A.

i have been able to do it but its:
1. When i import files, these two values are not getting imported for all files (but for few files they are getting imported).
2. However if i import same folder second time then all fields and their value are getting imported.
See the code below

Sub GetFileList()
ChDrive "M"
ChDir "M:\Certificates"
     'Const cStartRow As Long = 2
     Const cFPathCol As Long = 1
     Const cExtentionCol As Long = 2
     Const cDatasetType As Long = 3
     Const cFNameCol As Long = 4
     Const cNamedReference As Long = 5
     Const cLog As Long = 6
 
     Dim ThisFolder As String
     Dim ThisFile As String
     Dim FileName As String
     Dim Extention As String
     Dim i As Long
 
    If SelectDirectoryOK(ThisFolder) Then
         ThisFile = Dir(ThisFolder & "\*.*")
         i = Cells(50000, cFPathCol).End(xlUp).Offset(1, 0).Row
         'i = cStartRow
         Do Until ThisFile = ""
 
             FileName = Left(ThisFile, InStrRev(ThisFile, ".") - 1)
             Extention = Mid(ThisFile, InStrRev(ThisFile, ".") + 1)
 
             Cells(i, cFPathCol) = ThisFolder & "\" & FileName & "." & Extention
             Cells(i, cExtentionCol) = Extention
             Cells(i, cFNameCol) = FileName
             Call CopyTeamCentreValue(Extention, i)
             'Cells(i, cDatasetType) = DataSetValue(Extention, i)
             'Cells(i, cNamedReference) = NamedReferenceFunction(Extention)
             Cells(i, cLog) = "import.log"
             i = i + 1
             ThisFile = Dir
         Loop
    End If
End Sub
 
 Function SelectDirectoryOK(ByRef Directory As String, Optional InitialPath As String = "") As Boolean
     SelectDirectoryOK = False
 
     With Application.FileDialog(msoFileDialogFolderPicker)
         If InitialPath <> "" Then .InitialFileName = InitialPath
         .Title = "Select File FOLDER"
         .AllowMultiSelect = False
         .Show
         If .SelectedItems.Count = 0 Then Exit Function
         Directory = .SelectedItems(1)
     End With
 
     SelectDirectoryOK = True
 End Function
 
Sub CopyTeamCentreValue(Extention As String, i As Long)
  'Copy cells of cols A,F,E,D from rows containing "Significant" in
  'col D of the active worksheet (source sheet) to cols
  'A,B,C,D of Sheet2 (destination sheet)
  Dim DestSheet As Worksheet
  Const cDatasetType As Long = 3
  Const cNamedReference As Long = 5
  Dim SourceSheet As Worksheet
  Set DestSheet = Worksheets("Import File Utility")
  Set SourceSheet = Worksheets("TeamCenterVsFileMapping")
 
  Dim sRow As Long     'row index on source worksheet
  Dim dRow As Long     'row index on destination worksheet
  Dim sCount As Long
  dRow = i
  For sRow = 2 To Range("A65536").End(xlUp).Row
     'use pattern matching to find "File Type" anywhere in cell
     If SourceSheet.Cells(sRow, "A") = Extention Then
        'copy cols A,F,E & D
         'SourceSheet.Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, cDatasetType)
        DestSheet.Cells(dRow, cDatasetType) = SourceSheet.Cells(sRow, "B")
        'DestSheet.Cells(i, cNamedReference) = SourceSheet.Cells(sRow, "C")
     End If
  Next sRow
End Sub
 
 

[MikeTheBike]

@prashantdixit
Hi again

Not to short this asnswers all you problems but I suggest you change the bit of code

For sRow = 2 To Range("A65536").End(xlUp).Row 
     'use pattern matching to find "File Type" anywhere in cell 
     If SourceSheet.Cells(sRow, "A") = Extention Then 
        'copy cols A,F,E & D 
         'SourceSheet.Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, cDatasetType) 
        DestSheet.Cells(dRow, cDatasetType) = SourceSheet.Cells(sRow, "B") 
        'DestSheet.Cells(i, cNamedReference) = SourceSheet.Cells(sRow, "C") 
     End If 
  Next sRow 

to this

For sRow = 2 To SourceSheet.Range("A65536").End(xlUp).Row
     'use pattern matching to find "File Type" anywhere in cell
     If Trim(UCase(SourceSheet.Cells(sRow, "A"))) = Trim(UCase(Extention)) Then
        'copy cols A,F,E & D
         'SourceSheet.Cells(sRow, "B").Copy Destination:=DestSheet.Cells(dRow, cDatasetType)
        DestSheet.Cells(dRow, cDatasetType) = SourceSheet.Cells(sRow, "B")
        'DestSheet.Cells(i, cNamedReference) = SourceSheet.Cells(sRow, "C")
     End If
  Next sRow

Using Trim() and UCase() will remove any ambiguity with leading and trailing spaces and make it case insensity.

I have also added the sourcesheet reference when finding the last row in the source sheet (as it was you were finding the last row in the currently active sheet, which is the destination sheet!).

Other than that, ity seem to work OK.

HTH


MTB

[prashantdixit]

Thanks again.
it worked