Copy data based upon cell value

Closed
Report
Posts
4
Registration date
Thursday November 27, 2014
Status
Member
Last seen
December 3, 2014
-
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
-
Hello,

Need help on copying data from file1.xlsx into multiple .xlsx file based upon column G values.
The file1.xlsx contains...
Column F Column G Column H
Data1 Name1 Test1
Data2 Name2 Test2
Data3 Name3 Test
Data Name2 Test3
Dataw Name3 Test5

Based upon column G I am copying a template .xlsx file and rename them with Column G unique data and updating some of the cell values in template. However fail to copy column data based upon Column G...which should looks like in output as....

Name1.xlsx...
Column A Column B
Data1 Test1

Name2.xlsx...
Column A Column B
Data2 Test2
Data Test3

and so on...

Can you please provide any reference or sample code for this.

Thanks & Regards,
ShailShin

3 replies

Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
Have a look at this
https://ccm.net/forum/affich-258700-interesting-question-for-excel-champions

You would want to copy column G to a temp area/sheet to get the unique value. Then for each unique value you can copy a template and do the needful.
Posts
4
Registration date
Thursday November 27, 2014
Status
Member
Last seen
December 3, 2014

Hi,
Below is what I have tried with the reference code. In this, based upon the file1.xlsx this copy the template from the specific location and update the couple of cell in the copied template. However, how do I copy the other data for unique cell value in this copied template? As, I have to copy the data even for the cell value is duplicated. as mentioned in initial thread.

Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Dim email As String
Dim pm As String
Dim data As String

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:\Template.xlsx" 'template file to copy
copyTo = "D:\Generate\s\" 'location where copied files need to be copied

Do
x = x + 1

colA = Range("G" & x).Value 'col a value
email = Range("H" & x).Value
pm = Range("F" & x).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 Example(copyTo, wbName, email, pm)
Loop Until x = lRow

Set dic = Nothing ' clean up
Set fso = Nothing ' clean up

End Sub
Sub Example(filepath As String, vndr As String, vemail As String, pname As String)
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean

'Fill in the path\folder where the files are
MyPath = filepath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & vndr & ".xlsx")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then


'Change cell value(s) in one worksheet in mybook
On Error Resume Next
With mybook.Worksheets(1)
If .ProtectContents = False Then
.Range("C6").Value = vndr
.Range("C7").Value = vemail
.Range("E20").Value = pname
Else
ErrorYes = True
End If
End With


If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If

Next Fnum
End If

If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If

'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
So once you have updated your target file, go back to the source file. Filter the sheet on the value (column G in your example. Now source file is only showing you the data that can be copied. Copy and paste in the target sheet. The example I gave you is doing similar thing
The example shows as number of sheets has been added. how to achieve the same for multiple xlsx file updates?

Thanks,
ShailShin
Posts
4
Registration date
Thursday November 27, 2014
Status
Member
Last seen
December 3, 2014

Hi All,

Added function to copy the data in copied template file but it fails to copy the data with the given search string.

Sub copyTemplate()
Dim lRow, x As Integer
Dim wbName As String
Dim fso As Variant
Dim dic As Variant
Dim colA As String
Dim colB As String
Dim colSep As String
Dim copyFile As String
Dim copyTo As String
Dim email As String
Dim pm As String
Dim data As String

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 = "D:\Generate\s\" 'location where copied files need to be copied

Do
x = x + 1

colA = Range("G" & x).Value 'col a value
email = Range("H" & x).Value
pm = Range("F" & x).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 Example(copyTo, wbName, email, pm, data)


Loop Until x = lRow

Set dic = Nothing ' clean up
Set fso = Nothing ' clean up

End Sub
Sub Example(filepath As String, vndr As String, vemail As String, pname As String, data As String)
Dim MyPath As String, FilesInPath As String
Dim MyFiles() As String, Fnum As Long
Dim mybook As Workbook
Dim CalcMode As Long
Dim sh As Worksheet
Dim ErrorYes As Boolean

'Fill in the path\folder where the files are
MyPath = filepath

'Add a slash at the end if the user forget it
If Right(MyPath, 1) <> "\" Then
MyPath = MyPath & "\"
End If

'If there are no Excel files in the folder exit the sub
FilesInPath = Dir(MyPath & vndr & ".xlsx")
If FilesInPath = "" Then
MsgBox "No files found"
Exit Sub
End If

'Fill the array(myFiles)with the list of Excel files in the folder
Fnum = 0
Do While FilesInPath <> ""
Fnum = Fnum + 1
ReDim Preserve MyFiles(1 To Fnum)
MyFiles(Fnum) = FilesInPath
FilesInPath = Dir()
Loop

'Change ScreenUpdating, Calculation and EnableEvents
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With

'Loop through all files in the array(myFiles)
If Fnum > 0 Then
For Fnum = LBound(MyFiles) To UBound(MyFiles)
Set mybook = Nothing
On Error Resume Next
Set mybook = Workbooks.Open(MyPath & MyFiles(Fnum))
On Error GoTo 0

If Not mybook Is Nothing Then


'Change cell value(s) in one worksheet in mybook
On Error Resume Next
With mybook.Worksheets(1)
If .ProtectContents = False Then
.Range("C6").Value = vndr
.Range("C7").Value = vemail
.Range("E20").Value = pname
.Range("C20").Value = SearchForString(vndr)
Else
ErrorYes = True
End If
End With


If Err.Number > 0 Then
ErrorYes = True
Err.Clear
'Close mybook without saving
mybook.Close savechanges:=False
Else
'Save and close mybook
mybook.Close savechanges:=True
End If
On Error GoTo 0
Else
'Not possible to open the workbook
ErrorYes = True
End If

Next Fnum
End If

If ErrorYes = True Then
MsgBox "There are problems in one or more files, possible problem:" _
& vbNewLine & "protected workbook/sheet or a sheet/range that not exist"
End If

'Restore ScreenUpdating, Calculation and EnableEvents
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub
Function SearchForString(filename As String)

Dim LSearchRow As Integer
Dim LCopyToRow As Integer

'Set mybook = Workbooks.Open(MyPath & "POSummary.xlsm")

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 = filename Then

'Select row in Sheet1 to copy
Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
Selection.Copy

'Paste row into Sheet2 in next row
Sheets("Sheet1").Select
Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
ActiveSheet.Paste

'Move counter to next row
LCopyToRow = LCopyToRow + 1

'Go back to Sheet1 to continue searching
Sheets("Sheet1").Select

End If

LSearchRow = LSearchRow + 1

Wend

'Position on cell A3
Application.CutCopyMode = False
Range("A3").Select

MsgBox "All matching data has been copied."

Exit Function

Err_Execute:
MsgBox "An error occurred."

End Function
Posts
4476
Registration date
Thursday January 28, 2010
Status
Contributor
Last seen
August 2, 2020
768
?what is the error

in err_execute, change to say
"An error occured. " + Err.Number