-
Dec 4th, 2014, 04:50 AM
#1
Thread Starter
Registered User
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
-
Dec 4th, 2014, 07:40 AM
#2
Re: Copy cell values to target excel file.
-
Dec 5th, 2014, 12:21 AM
#3
Thread Starter
Registered User
Re: Copy cell values to target excel file.
Yes I got the error message "An error occurred."
-
Dec 5th, 2014, 07:57 AM
#4
Re: Copy cell values to target excel file.
And what line gives you that?
-
Dec 7th, 2014, 11:48 PM
#5
Thread Starter
Registered User
Re: Copy cell values to target excel file.
After on this line...
Sheets("Sheet1").Select
-
Dec 8th, 2014, 12:49 PM
#6
Re: Copy cell values to target excel file.
And if you type this:
into the Watch window, what "Type" does it say it is?
-
Dec 8th, 2014, 11:56 PM
#7
Thread Starter
Registered User
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
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|