Hi All,
I am trying to work on a code that would enable me to copy data from the raw file and update the individual sheets in the master workbook for each value in column A of raw file.Background: There are many unique IDs mentioned in column A of the raw file, other columns contain corresponding data to each unique id. Each unique ID has a separate sheet in the master workbook.Requirement:
- Remove unwanted unique ids mentioned in the to be removed sheet in raw file
- Copy the entire row from the raw file, locate the relevant unique ID sheet in the master workbook and paste the data in the last row.
- In case the unique id sheet is not there in the master workbook then to create it and paste the data.
Problem:
- The code that I have gets stuck on locating the correct sheet in the master, it is unable to locate the sheet and when it goes to create a new sheet with the name it gives the error that the sheet name already exists.
- In case there is a requirement to create a new sheet for a unique id, it should continue looping and paste data for other ids as well.
- It should give a message box in the end giving details of all new sheets that were created.
Code
Sub unique_ids()
Dim NewFN As String, MasterFN As String
Dim lrow As Long, i As Long, drow As Long, j as Long
Dim rngf As Range, rngv As Range
Dim SName As Variant
Dim FoundDup As Range
'Open the Master file
proceed:
MasterFN = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*", Title:="Please open the Master File")
If MasterFN = "" Then
MsgBox "You have not selected a file."
GoTo proceed
Else
Workbooks.Open Filename:=MasterFN
End If
MasterFN = ActiveWorkbook.Name
'Open the raw file
proceed1:
NewFN = Application.GetOpenFilename(FileFilter:="All files (*.*), *.*", Title:="Please open the raw File")
If NewFN = "" Then
MsgBox "You have not selected a file."
GoTo proceed1
Else
Workbooks.Open Filename:=NewFN
End If
'Save backup file
ActiveWorkbook.SaveAs Filename:="D:\Counts-" & Format(Date, "dd-mmm-yy") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
Workbooks("Counts-" & Format(Date, "dd-mmm-yy") & ".xlsx").Close
Workbooks.Open Filename:=NewFN
NewFN = ActiveWorkbook.Name
'Delete the "to be removed" IDs
Sheets("counts").Select
For Row = Range("A65536").End(xlUp).Row To 2 Step -1
Set FoundDup = Sheets("To be deleted").Range("A:A").Find(Cells(Row, 1), LookIn:=xlValues, lookat:=xlWhole)
If Not FoundDup Is Nothing Then
Cells(Row, 1).EntireRow.Delete
End If
Next Row
‘Update Data
For j = 2 To lrow
SName = Workbooks(NewFN).Worksheets("counts").Range("K" & i).Value
On Error GoTo new_tab
Workbooks(NewFN).Worksheets("Counts").Range("A" & i & ":I" & i).Copy Workbooks(MasterFN).Worksheets(SName).Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Workbooks(MasterFN).Worksheets(SName).Range("A" & Rows.Count).End(xlUp).Value = Format(Date, "dd-mmm-yy")
drow = Workbooks(MasterFN).Worksheets(SName).Range("K" & Rows.Count).End(xlUp).Offset(-1, 0).Row
Workbooks(MasterFN).Worksheets(SName).Range("K" & drow - 1 & ":S" & drow - 1).Copy Workbooks(MasterFN).Worksheets(SName).Range("K" & drow & ":S" & drow)
Next j
new_tab:
MsgBox "New ID encountered", vbCritical
Workbooks(MasterFN).Sheets.Add(after:=Workbooks(MasterFN).Sheets(Worksheets.Count)).Name = SName
Workbooks(NewFN).Worksheets("counts").Range("A" & i & ":I" & i).Copy Workbooks(MasterFN).Worksheets(SName).Range("B" & Rows.Count).End(xlUp)
Workbooks(MasterFN).Worksheets(SName).Range("A" & Rows.Count).End(xlUp).Value = Format(Date, "dd-mmm-yy")
drow = Workbooks(MasterFN).Worksheets(SName).Range("K" & Rows.Count).End(xlUp)
Workbooks(MasterFN).Worksheets(SName).Range("K" & drow - 1 & ":S" & drow - 1).Copy Workbooks(MasterFN).Worksheets(SName).Range("K" & drow & ":S" & drow)
MsgBox "This work is now complete, new sheet added - " & SName
End Sub
Display More
Thanks