Copy column's data from multiple excel files and paste it in new excel file

Question

I want to copy a specific column from the excel files located in a folder and paste all the values in a new excel sheet.

Completed-

1. I am able to loop through all the files located in a folder.
2. I am able to copy the data from specific column.

Not able to complete:

1. Not able able to paste the copied data.
2. I want to copy only the distinct values.
3. I want to copy columns till the rows are there. like if there are 7 rows then copy 7 values of column. My copy command is copying all the values up to last row of excel sheet.

My code (VBScipt)-

strPath="C:\Test"

Set objExcel= CreateObject("Excel.Application")
objExcel.Visible= True

Set objExcel2= CreateObject("Excel.Application")
objExcel2.Visible= True

objExcel2.Workbooks.open("C:\Test\New Folder\4.xlsx")

Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFolder = objFso.GetFolder (strPath)

For Each objFile In objFolder.Files
If objFso.GetExtensionName(objFile.Path) = "xlsx" Then
    objExcel.Workbooks.Open(objFile.Path)

    Set Source=objExcel.Activeworkbook.Sheets(1).Columns("G")
    Source.Copy
    Set dest=objExcel2.Activeworkbook.Sheets(1).Columns("A")
    dest.Paste
    objExcel.Activeworkbook.save
    objExcel.Activeworkbook.close
    objExcel2.Activeworkbook.save
    objExcel2.Activeworkbook.close



End If

Next

Answer 1

This function will return the used range for a given column on a worksheet.

Private Function getRange(ByVal ColumnName As String, ByVal Sheet As Worksheet) As Range
  Set getRange = Sheet.Range(ColumnName & "1", ColumnName & Sheet.Range(ColumnName & Sheet.Columns(ColumnName).Rows.Count).End(xlUp).Row)
End Function

If you use this in-place of your Set Source=objExcel.Activeworkbook.Sheets(1).Columns("G") it should do what you want.

eg: Set Source = getRange("G", objExcel.Activeworkbook.Sheets(1))

You might need to change your dest to a cell instead of the column (in-case excel moans about it being the wrong size)

Set dest = objExcel.Activeworkbook.Sheets(1).Cells("A1")

Just saw that you tagged it as VBScript, I haven't tested it as VBS but it might work just the same as VBA.

Answer 2

For distinct copying .AdvancedFilter() method used, cells defined with getRange() from @NickSlash. For data addition from files, new sheet is created for each of them, and then data is filtered to it. I hope this helps.
VBScript

Const xlFilterCopy = 2
Const xlUp = -4162
Const xlDown = -4121
strPathSrc = "C:\Test" ' Source files folder
strMaskSrc = "*.xlsx" ' Source files filter mask
iSheetSrc = 1 ' Sourse sheet index or name
iColSrc = 7 ' Source column index, e. g. 7 for "G"
strPathDst = "C:\Test\New Folder\4.xlsx" ' Destination file
iColDst = 1 ' Destination column index

Set objExcel = CreateObject("Excel.Application")
objExcel.Visible = True
Set objWorkBookDst = objExcel.Workbooks.Open(strPathDst)
Set objSheetTmp = objWorkBookDst.Worksheets.Add
objSheetTmp.Cells(1, iColDst).Value = "TempHeader"
Set objShellApp = CreateObject("Shell.Application")
Set objFolder = objShellApp.NameSpace(strPathSrc)
Set objItems = objFolder.Items()
objItems.Filter 64 + 128, strMaskSrc
objExcel.DisplayAlerts = False
For Each objItem In objItems
    Set objWorkBookSrc = objExcel.Workbooks.Open(objItem.Path)
    Set objSheetSrc = objWorkBookSrc.Sheets(iSheetSrc)
    objSheetSrc.Cells(1, iColSrc).Insert xlDown
    objSheetSrc.Cells(1, iColSrc).Value = "TempHeader"
    Set objRangeSrc = GetRange(iColSrc, objSheetSrc)
    If objRangeSrc.Cells.Count > 1 then
        nNextRow = GetRange(iColDst, objSheetTmp).Rows.Count + 1
        objRangeSrc.AdvancedFilter xlFilterCopy, , objSheetTmp.Cells(nNextRow, iColDst), True
        objSheetTmp.Cells(nNextRow, iColDst).Delete xlUp
        Set objRangeTmp = GetRange(iColDst, objSheetTmp)
        Set objSheetDst = objWorkBookDst.Worksheets.Add
        objRangeTmp.AdvancedFilter xlFilterCopy, , objSheetDst.Cells(1, iColDst), True
        objSheetTmp.Delete
        Set objSheetTmp = objSheetDst
    End If
    objWorkBookSrc.Close
Next
objSheetTmp.Cells(1, iColDst).Delete xlUp
objExcel.DisplayAlerts = True

Function GetRange(iColumn, objSheet)
    With objSheet
        Set GetRange = .Range(.Cells(1, iColumn), .Cells(.Cells(.Cells.Rows.Count, iColumn).End(xlUp).Row, iColumn))
    End With
End Function

Answer 3

I think PasteSpecial will help with the pasting in vb script. It is best to use the -4163 argument in PasteSpecial to ensure that only the values are pasted. The code below worked for me in Microsoft Visual Studio 2012. Added comments just to know where the program is in the code. Hope this helps.

Imports System.Data.OleDb
Imports System.IO
Imports System.Text

Public Class Form1
 Dim objCSV, objExcel, objSourceWorkbook, objDestWorkbook, objCSVWorkSheet, objXLSWorkSheet, srcCPUXrange, srcCPUYrange, srcMEMYrange, dstCPUXrange, dstCPUYrange, dstMEMYRange
   Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load

 'Create and open source CSV object
    Label1.Text = "Setting Source"
    objCSV = CreateObject("Excel.Application")
    objCSV.Visible = True
    objSourceWorkbook = objCSV.Workbooks.Open("C:\SourceFile.csv")
    Label1.Text = "Source set"

    'Create and open destination Excel object
    Label1.Text = "Setting Destination"
    objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True
    objDestWorkbook = objExcel.Workbooks.Open("C:\DestinationFile.xlsx")
    Label1.Text = "Destination Set"

    'Select desired range from CSV file
    Label1.Text = "Copying Data"
    objCSVWorkSheet = objSourceWorkbook.Worksheets(1)
    objCSVWorkSheet.Activate()
    objSourceWorkbook.Worksheets(1).Range("A1").EntireColumn.Copy()
    Label1.Text = "Data Copied"

    'Paste in Excel workbook 
    Label1.Text = "Pasting Data"
    objXLSWorkSheet = objDestWorkbook.Worksheets(1)
    objXLSWorkSheet.Activate()
    objDestWorkbook.Worksheets(1).Range("A2").PasteSpecial(-4163)
    Label1.Text = "Data Pasted"    


  End Sub
End Class