Results 1 to 7 of 7

Thread: Copy cell values to target excel file.

  1. #1

    Thread Starter
    Registered User
    Join Date
    Dec 2014
    Posts
    4

    Copy cell values to target excel file.

    Hi All,

    1. User select summary xlsx filepath
    2. Based upon column G unique values copy the template from specific location and rename with column G unique cell value.
    3. Also, copy data from B,C,E,F,J and K if column G contains "Unique Value" and paste it in copied file in cell C20:H20 + 1 depends upon the column G values occurrences.

    Here is my existing code....which fails to copy the data from summary xlsx file.
    Code:
    Sub Generate_VFiles()
        Dim MyPath As String, FilesInPath As String
        Dim MyFiles() As String
        Dim SourceRcount As Long, Fnum As Long
        Dim mybook As Workbook, BaseWks As Worksheet
        Dim sourceRange As Range, destrange As Range
        Dim rnum As Long, CalcMode As Long
        Dim fldr As FileDialog
        Dim sItem As String
        Dim copyFile   As String
        Dim copyTo     As String
        Dim wbname As String
        Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
        With fldr
            .Title = "Select Folder"
            .AllowMultiSelect = False
            .InitialFileName = strPath
            If .Show <> -1 Then GoTo NextCode
            sItem = .SelectedItems(1)
        End With
    NextCode:
    Set fldr = Nothing
    MyPath = sItem
    
    If Right(MyPath, 1) <> "\" Then
            MyPath = MyPath & "\"
        End If
        
        FilesInPath = Dir(MyPath & "*.xl*")
        If FilesInPath = "" Then
            MsgBox "No files found"
            Exit Sub
        End If
        
         Set summarybook = Workbooks.Open(MyPath & FilesInPath)
        
        Set dic = CreateObject("Scripting.Dictionary") 'dictionary to ensure that duplicates are not created
        Set fso = CreateObject("Scripting.FileSystemObject") 'file scripting object for fiile system manipulation
        
        colSep = "_" 'separater between values of col A and col B for file name
       dic.Add colSep, vbNullString ' ensuring that we never create a file when both columns are blank in between
       
       'get last used row in col A
       lRow = Range("G" & Rows.Count).End(xlUp).Row
       
       x = 1
       copyFile = "C:\temp\Template.xlsx" 'template file to copy
       copyTo = MyPath 'location where copied files need to be copied
       
       Do
        x = x + 1
        
        colA = Range("G" & x).Value 'col a value
          
        wbname = colA ' create new file name
        
        If (Not dic.Exists(wbname)) Then 'ensure that we have not created this file name before
          fso.copyFile copyFile, copyTo & wbname & ".xlsx" 'copy the file
          dic.Add wbname, vbNullString 'add to dictionary that we have created this file
       End If
       
       Call SearchForString(wbname, FilesInPath, MyPath)
       
    Loop Until x = lRow
    
    Set dic = Nothing ' clean up
    Set fso = Nothing ' clean up
    summarybook.Close
       
    End Sub
    Sub SearchForString(searchstr As String, summaryfile As String, filepath As String)
        
       Dim LSearchRow As Integer
       Dim LCopyToRow As Integer
       
       
       Set mybook = Workbooks(summaryfile)
       
       On Error GoTo Err_Execute
          
       'Start search in row 1
       LSearchRow = 1
       
       'Start copying data to row 2 in Sheet2 (row counter variable)
       LCopyToRow = 20
       
       While Len(Range("G" & CStr(LSearchRow)).Value) > 0
       
          'If value in column E = "Mail Box", copy entire row to Sheet2
          If Range("G" & CStr(LSearchRow)).Value = searchstr Then
          
             'Select row in Sheet1 to copy
             
             Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
             Selection.Copy
             
             'Paste row into Sheet2 in next row
             Set mytarget = Workbooks(filepath & searchstr & ".xlsx")
             
             Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
             ActiveSheet.Paste
             
             'Move counter to next row
             LCopyToRow = LCopyToRow + 1
             
             'Go back to Sheet1 to continue searching
             mybook.Activate
            Sheets("Sheet1").Select
             
          End If
          
          LSearchRow = LSearchRow + 1
          
       Wend
       
       'Position on cell A3
       Application.CutCopyMode = False
       Range("A3").Select
       mybook.Close
       MsgBox "All matching data has been copied."
       
       Exit Sub
       
    Err_Execute:
       MsgBox "An error occurred."
       
    End Sub
    Can you please provide the solution or any reference for this?

    Thanks in Advance,
    ShailShin

  2. #2
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: Copy cell values to target excel file.

    Do you get an error?

  3. #3

    Thread Starter
    Registered User
    Join Date
    Dec 2014
    Posts
    4

    Re: Copy cell values to target excel file.

    Yes I got the error message "An error occurred."

  4. #4
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: Copy cell values to target excel file.

    And what line gives you that?

  5. #5

    Thread Starter
    Registered User
    Join Date
    Dec 2014
    Posts
    4

    Re: Copy cell values to target excel file.

    After on this line...
    Sheets("Sheet1").Select

  6. #6
    PowerPoster
    Join Date
    Oct 2008
    Location
    Midwest Region, United States
    Posts
    3,574

    Re: Copy cell values to target excel file.

    And if you type this:

    Code:
    Sheets("Sheet1")
    into the Watch window, what "Type" does it say it is?

  7. #7

    Thread Starter
    Registered User
    Join Date
    Dec 2014
    Posts
    4

    Re: Copy cell values to target excel file.

    Hi,
    I made some changes in the second sub...

    1. copy entrie row from file1.xlsx file.
    2. open copied file and select cell C20 and paste the copied row.
    3. again look for the value if it is there for same unique cell value and do the same process until value changed....Here I am getting an message saying xyz.xlsx file is already open and instead of entire row i would like to copy only the mentioned ones (B,C,E,F,J and K if column G contains "Unique Value" )...Please provide the solution for this to achieve.

    Code:
    Sub SearchForString(searchstr As String, summaryfile As String, filepath As String)
        
       Dim LSearchRow As Integer
       Dim LCopyToRow As Integer
       
       
       Set mybook = Workbooks(summaryfile)
       
       On Error GoTo Err_Execute
          
       'Start search in row 1
       LSearchRow = 1
       
       'Start copying data to row 2 in Sheet2 (row counter variable)
       LCopyToRow = 20
       
       While Len(Range("G" & CStr(LSearchRow)).Value) > 0
       
          'If value in column E = "Mail Box", copy entire row to Sheet2
          If Range("G" & CStr(LSearchRow)).Value = searchstr Then
          
             'Select row in Sheet1 to copy
             
             Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
             Selection.Copy
             
             'Paste row into Sheet2 in next row
             Set mytarget = Workbooks.Open(filepath & searchstr & ".xlsx")
             mytarget.Sheets("Invoice").Range("C20").Select
             Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
             ActiveSheet.Paste
             
             'Move counter to next row
             LCopyToRow = LCopyToRow + 1
             
             'Go back to Sheet1 to continue searching
             mybook.Activate
            Sheets("Sheet1").Select
             
          End If
          
          LSearchRow = LSearchRow + 1
          
       Wend
       
       'Position on cell A3
       Application.CutCopyMode = False
       Range("A3").Select
       mybook.Close
       MsgBox "All matching data has been copied."
       
       Exit Sub
       
    Err_Execute:
       MsgBox "An error occurred."
       
    End Sub

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width