I'm trying to copy a worksheet ("ReceivingRecords") from the workbook ("InventoryControlSystemV1.1") and paste it in a new workbook ("RecordBook"). I have created a temporary workbook named "Temp.xls" which allows me to use the SaveCopyAs method to create my new workbook "RecordBook".
When I run the procedure, "RecordBook" is created as intended but with only one entry (The text 'InventoryControlSystemV1.1.xls') in cell A1.
The worksheet that I want to copy is then pasted into a new, unnamed, workbook.
I can't figure out where or why this new workbook is being created.
Here is the code for this procedure:
Sub WriteReceivingToRecords()
Dim UsedRng As Range
Dim LastCol As Long
Dim BeginDate, EndDate
Dim NameString
Dim FormatBeginDate, FormatEndDate
Dim BackupQuest As Integer
Dim BackupMsg As String
'Confirmation dialog box to avoid mistakes
BackupMsg = "This will create a new workbook for the period" & vbNewLine
BackupMsg = BackupMsg & " since the last backup was made, and will clear" & vbNewLine
BackupMsg = BackupMsg & " the receiving records in this workbook." & vbNewLine & vbNewLine
BackupMsg = BackupMsg & "Are you sure you want to back up the receiving records?"
BackupQuest = MsgBox(BackupMsg, vbYesNo, "Back-up Records")
If BackupQuest = vbNo Then
Exit Sub
Else
' Find start and end dates of receiving - To use for worksheet title
Workbooks("InventoryControlSystemV1.1.xls").Activate
Worksheets("ReceivingRecords").Activate
Set UsedRng = ActiveSheet.UsedRange
LastCol = UsedRng(UsedRng.Cells.Count).Column
Do While Cells(2, LastCol) = ""
LastCol = LastCol - 1
Loop
EndDate = Cells(2, LastCol).Text
BeginDate = Cells(2, 2).Text
FormatBeginDate = Format(BeginDate, "d mmmm yy")
FormatEndDate = Format(EndDate, "d mmmm yy")
NameString = "M-Props Receiving Records " & FormatBeginDate & " To " _
& FormatEndDate & ".xls"
Workbooks("InventoryControlSystemV1.1.xls").Sheets("ReceivingRecords").Copy
Workbooks.Open Filename:="Temp.xls"
Workbooks("Temp.xls").Activate
Workbooks("Temp.xls").Worksheets("Sheet1").Paste _
Destination:=Workbooks("Temp.xls").Worksheets("Sheet1").Range("A1")
Workbooks("Temp.xls").SaveCopyAs NameString & ".xls"
Workbooks("Temp.xls").Close False
End If
End Sub
Replace
Workbooks("InventoryControlSystemV1.1.xls").Sheets("ReceivingRecords").Copy
with
Workbooks("InventoryControlSystemV1.1.xls").Sheets("ReceivingRecords").Cells.Copy
That should do it.
Related
First of all I'd like to preface this by saying that I have less than a week's experience using VBA.
I have been trying to create a script that merges PDFs that are linked in an Excel sheet. The code that I have works fine, however, when I add multiple tables separated by empty rows, the script will continue to move down through the empty cells and collect the PDFs from the next table as well.
So if I select the bottom table to merge, it will work fine, but if I select the top one, it will merge all the linked PDFs for ALL the tables moving down.
Here is a screenshot of the Excel sheet I have at the moment:
Excel Sheet
What I would like is for the script to stop at the first empty cell it encounters while moving down column D, rather than continuing until the last populated cell. Meaning that the script will only merge one table of PDFs.
As I said, this is my first week using any VBA, so I have been struggling to get the range for the PDF merging to end when it encounters the empty cell.
Any help would be greatly appreciated!
Sub Button9_Click()
'References
'Adobe Acrobat 10.0 Type Library
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc
Dim objCAcroPDDocSource As Acrobat.CAcroPDDoc
Dim PDFfiles As Range, PDFfile As Range
Dim n As Long
Dim em As String
'Set start point of cell range
'Takes ActiveCell from search results and offsets to filepaths
'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN, DISREGARDING PREVIOUS EMPTY CELLS
With ActiveSheet
Set PDFfiles = .Range(ActiveCell.Offset(3, 1), .Cells(.Rows.Count, "D").End(xlUp))
End With
'Create Acrobat API objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open first PDF file and merge other PDF files into it
n = 0
For Each PDFfile In PDFfiles
n = n + 1
If n = 1 Then
objCAcroPDDocDestination.Open PDFfile.Value
Else
objCAcroPDDocSource.Open PDFfile.Value
If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Error merging" & PDFfile.Value
End If
objCAcroPDDocSource.Close
End If
Next
'Save merged PDF files as a new file
objCAcroPDDocDestination.Save 1, "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
'Opens dialogue box for successful/failed merge
MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").Value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
'Opens merged PDF
ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").Value & ".pdf"
End Sub
Try the next code, please:
Sub MergePDFDocuments()
'References to 'Adobe Acrobat 10.0 Type Library
Dim objCAcroPDDocDestination As Acrobat.CAcroPDDoc, objCAcroPDDocSource As Acrobat.CAcroPDDoc, i As Long
Dim PDFfiles As Range, PDFfile As Range, n As Long, em As String, processArr As String, prRng As Range
Dim sh As Worksheet, startRow As Long, endRow As Long
Set sh = ActiveSheet 'use here your sheet
processArr = "A" 'the group files to be processed.
'It can be "B", or other letter if the workbook will be filled with other groups
'CURRENTLY LOOKS FOR LAST POPULATED CELL IN COLUMN, DISREGARDING PREVIOUS EMPTY CELLS
'Set PDFfiles = sh.Range(sh.Offset(3, 1), sh.cells(rows.count, "D").End(xlUp))
endRow = sh.cells(rows.count, "D").End(xlUp).row
For i = 2 To endRow
If sh.Range("C" & i).value = "PRODUCT " & processArr Then
startRow = i + 2: Exit For
End If
Next i
If startRow >= i Then MsgBox "Strange..." & vbCrLf & _
"The area to be prcessed ""PRODUCT " & processArr & """ could not be found.": Exit Sub
'Create Acrobat API objects
Set objCAcroPDDocDestination = CreateObject("AcroExch.PDDoc")
Set objCAcroPDDocSource = CreateObject("AcroExch.PDDoc")
'Open first PDF file and merge other PDF files into it
For i = startRow To endRow
n = n + 1
If sh.Range("D" & i).value = "" Then Exit For 'iteration is interrupted in case of an empty cell in D:D:
If n = 1 Then
objCAcroPDDocDestination.Open sh.Range("D" & i).value
Else
objCAcroPDDocSource.Open sh.Range("D" & i).value
If Not objCAcroPDDocDestination.InsertPages(objCAcroPDDocDestination.GetNumPages - 1, _
objCAcroPDDocSource, 0, objCAcroPDDocSource.GetNumPages, 0) Then
MsgBox "Error merging: " & sh.Range("D" & i).value
End If
objCAcroPDDocSource.Close
End If
Next i
'Save merged PDF files as a new file. Here the pdf name can be assorted with the area to be processed (for instance PRODUCT A):
objCAcroPDDocDestination.Save 1, "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
objCAcroPDDocDestination.Close
Set objCAcroPDDocSource = Nothing
Set objCAcroPDDocDestination = Nothing
'Opens dialogue box for successful/failed merge
MsgBox "Created New PDF (" & Sheets("SEARCH").Range("E6").value & ")" & vbCrLf & vbCrLf & "File Path: C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
'Opens merged PDF
ActiveWorkbook.FollowHyperlink "C:\Users\USER\OneDrive\TEST MERGE\Output\" & Sheets("SEARCH").Range("E6").value & ".pdf"
End Sub
You must set processArr to be processed (A or B from your picture).
Code is not tested, but it should work. Please test it and send some feedback.
I have some vArrays which are not clearing out. The purspose of the macro is to work on a raw data tab which has 30+ tabs, each tab holding information for a specific office, 001-New York, etc. The macro is supposed to select x number of tabs (based on a reference file), copy them and save them into a new workbook. The problem is that instead of copying and saving from the raw data file it save the reference file instead. A For...Next loop is used to determine which tabs/offices to select & copy from the raw data file. The varrays are inside the loop and contain the names of the offices. When the code encounters the vArray the varray values are not clearing out when the loop circles back around.
Example:
'For 1' reference a cell with value of "8" so it populates 8 different vArray values (offices in this case). 'For 2' has a reference number of 5 and is supposed to populate 5 vArray values. It does this correctly as I can see the 5 new values in the locals window under vArray (1) thru vArray (5), however, vArray 6 thru 8 are showing values of the previous loop instead of 'Empty'. The vArray values are not clearing out when the macro loops.
sMasterListWBName is the reference file which tells the macro which tabs to copy from the raw data file and where to move the newly created workbook. The sub is also copying, saving, and distributing the reference file instead of the raw data file for some iterations of the loop (secondary issue--I will try to refrain from splitting the thread topic).
Thanks in advance to anyone who tries to answer this question.
Option Explicit
Dim iYear As Integer, iMonth As Integer, iVer As Integer, icount As Integer, iCount2 As Integer
Dim iLetter As String, iReport As String
Dim sMonth As String, sDate As String, sVer As String, sAnswer As String
Dim sFolderName As String, sManagerInitials As String
Dim iManagerNumber As Integer, iManagerStart As Integer, iTabNumber As Integer, iTabStart As Integer
Dim sMasterListWBName As String, sConsolidatedWBName As String, sExists As String
Dim oSheet As Object, oDistList As Object
Dim vArray(300) As Variant
Dim wbDistList As Workbook
Dim wsAgentListSheet As Worksheet, wsMain As Worksheet
Dim rCell As Range, rCell2 As Range, rCellTotal As Range
Public sFINorAgent As String
Sub Agent_Distribute()
On Error Resume Next
iYear = frm_fin_rep_main_distribute.txt_year
iMonth = frm_fin_rep_main_distribute.txt_month
iVer = frm_fin_rep_main_distribute.txt_version
sMonth = Right("0" & iMonth, 2)
sDate = iYear & "." & sMonth
sVer = "V" & iVer
sAnswer = MsgBox("Is the following information correct?" & vbNewLine & vbNewLine & _
"Report - " & frm_fin_rep_main.sLetter & vbNewLine & _
"Year - " & iYear & vbNewLine & _
"Month - " & sMonth & vbNewLine & _
"Name - " & frm_fin_rep_main.sReport & vbNewLine & _
"Version - " & sVer, vbYesNo + vbInformation, "Please verify...")
If sAnswer <> vbYes Then
Exit Sub
End If
Unload frm_fin_rep_main_distribute
frm_agent.Hide
Form_Progress
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
sConsolidatedWBName = ActiveWorkbook.Name
sMasterListWBName = "Dist Master List Final.xls"
If Not IsFileOpen(sMasterListWBName) Then
Workbooks.Open FileName:= _
"W:\Addins\01 GL - Distribution\" & sMasterListWBName, Password:="password"
Workbooks(sConsolidatedWBName).Activate
End If
Set oDistList = Workbooks(sMasterListWBName).Worksheets("Agent")
With oDistList
iManagerNumber = .Range("ManNumber2") 'range value = 66
For iManagerStart = 2 To iManagerNumber '2 to 66
If .Range("A" & iManagerStart) = "x" Then
iTabNumber = .Range("E" & iManagerStart) 'E2 to E66
sFolderName = .Range("F" & iManagerStart) 'F2 to F66
sManagerInitials = .Range("G" & iManagerStart) 'G2 to G66
For iTabStart = 1 To iTabNumber
vArray(iTabStart) = .Range("G" & iManagerStart).Offset(0, iTabStart)
Next iTabStart
If iTabNumber = 1 Then
Sheets(vArray(1)).Select
Else
Sheets(vArray(1)).Select
For iTabStart = 2 To iTabNumber
Sheets(vArray(iTabStart)).Select False
Next iTabStart
End If
ActiveWindow.SelectedSheets.Copy
' *** the following code is optional, remove preceding apostrophes from the following four lines to enable password protection ***
'For Each oSheet In ActiveWorkbook.Sheets
'oSheet.Protect "password"
'oSheet.EnableSelection = xlNoSelection
'Next
ActiveWorkbook.SaveAs FileName:= _
"W:\Financials\" & iYear & "\" & sDate & "\Report to Distribute Electronically\Department Reports\" _
& sFolderName & "\Current Year Financials" & "\" & "Y" & ") " & iYear & "-" & sMonth & " Agent Report Card " & sVer & " - " & sManagerInitials & ".xls"
ActiveWorkbook.Close
End If
iPercent = iManagerStart / iManagerNumber * 95
Task_Progress (iPercent)
Next iManagerStart
End With
Workbooks(sMasterListWBName).Close False
Task_Progress (100)
Unload frm_progress
Set oDistList = Nothing
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Message_Done
frm_agent.Show (vbModeless)
End Sub
I fixed it. I just added "Workbooks(sWbName).activate" at the end of the loop to make sure the focus is back on the raw data file. Now all files are saving in the correct format and location. Case closed unless someone has anything else to add. Maybe someone knows the reason the macro was losing sight of its active sheet (saving reference file instead of raw data file). Thank you.
I am testing a sample VB6 application which inserts text from TextBox to Excel.
I would like to find the last used row in the column, and append text from txt1 TextBox at the next row whenever user clicks a button.
The range is from C10 to C49.
After the last row is filled, I will prompt user to open new Excel file.
I am unable to do the appending part. Below is the code I tried:
Private Sub cmdUpdate_Click()
Dim objConn As New ADODB.Connection
Dim szConnect As String
szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\Excel\Format.xls;" & _
"Extended Properties='Excel 8.0;HDR=NO';"
objConn.Open szConnect
Dim xrow As Integer
Dim lastRow As Integer
lastRow = 10
xrow = 49
Do while lastRow <= xrow
objConn.Execute "UPDATE [Sheet1$C" & lastRow & ":C" & lastRow & "] SET F1 =" & txt1.Text & ";"
lastRow = lastRow + 1
Loop
End Sub
The code fills the whole range on each update. I know where my mistake is, but can't figure out proper way. How to make it insert only once until row 49?
Using Excel Object model is not an option as I want to be able to make updates when workbook is open in Excel.
Simple way to achieve this would be to declare your lastRow as more visible (e.g. as private member of your form class), drop looping, and increment lastRow only once per update:
Private lastRow As Integer
'...
objConn.Execute _
"UPDATE [Sheet1$C" & lastRow & ":C" & lastRow _
& "] SET F1 =" & txt1.Text & ";"
lastRow = lastRow + 1
If you assume no complete control over the target Excel range (e.g. data in the range may be modified between your updates, and you do not wish to overwrite those changes) then you could search for the first empty cell before every update. Use IsNull() to test for empty cells.
Private Const RANGE_IS_FULL As Long = -1
' Returns first vacant position in sRange Excel range (zero-based)
' Returns RANGE_IS_FULL if no vacant position was found
' sConnectionString: connection string to Excel workbook
' sRange: Excel range of a form [Sheet1$C10:C49]
Private Function GetNextAppendPosition(sConnectionString As String _
, sRange As String) As Long
Dim lRow As Long
Dim oRS As ADODB.Recordset
Set oRS = New ADODB.Recordset
oRS.CursorLocation = ADODB.adUseClient
oRS.Open "SELECT F1 FROM " & sRange _
, sConnectionString
oRS.MoveFirst
GetNextAppendPosition = RANGE_IS_FULL
lRow = -1
While Not oRS.EOF
lRow = lRow + 1
If IsNull(oRS.Fields(0).Value) Then
GetNextAppendPosition = lRow
GoTo hExit
End If
oRS.MoveNext
Wend
hExit:
oRS.Close
End Function
With this in mind, your update routine could be coded as this:
Public Sub ExportTextToExcelRow(sText As String)
Const CONNECTION_STRING As String = _
"Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\src\Excel ADO\Book1.xls;" & _
"Extended Properties='Excel 8.0;HDR=NO'; "
Const MAX_TARGET_ROW As Long = 49
Const MIN_TARGET_ROW As Long = 10
Const TARGET_COL As String = "C"
Const TARGET_SHEET As String = "Sheet1"
Dim lRow As Long
Dim oConn As New ADODB.Connection
Dim sTargetRange As String
sTargetRange = "[" & TARGET_SHEET & "$" & TARGET_COL & MIN_TARGET_ROW _
& ":" & TARGET_COL & MAX_TARGET_ROW & "]"
lRow = GetNextAppendPosition(CONNECTION_STRING, sTargetRange)
If lRow = RANGE_IS_FULL Then
MsgBox "Oops, range is full."
Exit Sub
End If
lRow = lRow + MIN_TARGET_ROW
sTargetRange = "[" & TARGET_SHEET & "$" & TARGET_COL & lRow _
& ":" & TARGET_COL & lRow & "]"
oConn.Open CONNECTION_STRING
oConn.Execute "UPDATE " & sTargetRange & " SET F1 = """ & sText & """;"
oConn.Close
End Sub
Call it from your event handler this way:
Private Sub cmdUpdate_Click()
ExportTextToExcelRow txt1.Text
End Sub
Can somebody help me with this code, I am getting a subscript out of range error:
The line after the 'creating the sheets is highlighted in yellow in debugger
'Validation of year
If TextBox_Year.Value = Format(TextBox_Year.Value, "0000") Then
'Creating Process
'Creation of new sheet
Workbooks.Add
ActiveWorkbook.SaveAs FileName:= _
"" & Workbooks("Temperature Charts Sheet Creator").Sheets("MENU").Cells(4, 12).Value & "Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value & ".xls", FileFormat _
:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:= _
False, CreateBackup:=False
'Creating of the sheets
Windows("Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value & ".xls").Activate
Sheets("Sheet3").Select
Sheets("Sheet3").Name = "31 " & ComboBox_Month.Value
Sheets("Sheet2").Select
Sheets("Sheet2").Name = "30 " & ComboBox_Month.Value
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "29 " & ComboBox_Month.Value
For i = 28 To 1 Step -1
Sheets.Add
ActiveSheet.Name = i & " " & ComboBox_Month.Value
Next
Suggest the following simplification: capture return value from Workbooks.Add instead of subscripting Windows() afterward, as follows:
Set wkb = Workbooks.Add
wkb.SaveAs ...
wkb.Activate ' instead of Windows(expression).Activate
General Philosophy Advice:
Avoid use Excel's built-ins: ActiveWorkbook, ActiveSheet, and Selection: capture return values, and, favor qualified expressions instead.
Use the built-ins only once and only in outermost macros(subs) and capture at macro start, e.g.
Set wkb = ActiveWorkbook
Set wks = ActiveSheet
Set sel = Selection
During and within macros do not rely on these built-in names, instead capture return values, e.g.
Set wkb = Workbooks.Add 'instead of Workbooks.Add without return value capture
wkb.Activate 'instead of Activeworkbook.Activate
Also, try to use qualified expressions, e.g.
wkb.Sheets("Sheet3").Name = "foo" ' instead of Sheets("Sheet3").Name = "foo"
or
Set newWks = wkb.Sheets.Add
newWks.Name = "bar" 'instead of ActiveSheet.Name = "bar"
Use qualified expressions, e.g.
newWks.Name = "bar" 'instead of `xyz.Select` followed by Selection.Name = "bar"
These methods will work better in general, give less confusing results, will be more robust when refactoring (e.g. moving lines of code around within and between methods) and, will work better across versions of Excel. Selection, for example, changes differently during macro execution from one version of Excel to another.
Also please note that you'll likely find that you don't need to .Activate nearly as much when using more qualified expressions. (This can mean the for the user the screen will flicker less.) Thus the whole line Windows(expression).Activate could simply be eliminated instead of even being replaced by wkb.Activate.
(Also note: I think the .Select statements you show are not contributing and can be omitted.)
(I think that Excel's macro recorder is responsible for promoting this more fragile style of programming using ActiveSheet, ActiveWorkbook, Selection, and Select so much; this style leaves a lot of room for improvement.)
Subscript out of Range error occurs when you try to reference an Index for a collection that is invalid.
Most likely, the index in Windows does not actually include .xls. The index for the window should be the same as the name of the workbook displayed in the title bar of Excel.
As a guess, I would try using this:
Windows("Data Sheet - " & ComboBox_Month.Value & " " & TextBox_Year.Value).Activate
Option Explicit
Private Sub CommandButton1_Click()
Dim mode As String
Dim RecordId As Integer
Dim Resultid As Integer
Dim sourcewb As Workbook
Dim targetwb As Workbook
Dim SourceRowCount As Long
Dim TargetRowCount As Long
Dim SrceFile As String
Dim TrgtFile As String
Dim TitleId As Integer
Dim TestPassCount As Integer
Dim TestFailCount As Integer
Dim myWorkbook1 As Workbook
Dim myWorkbook2 As Workbook
TitleId = 4
Resultid = 0
Dim FileName1, FileName2 As String
Dim Difference As Long
'TestPassCount = 0
'TestFailCount = 0
'Retrieve number of records in the TestData SpreadSheet
Dim TestDataRowCount As Integer
TestDataRowCount = Worksheets("TestData").UsedRange.Rows.Count
If (TestDataRowCount <= 2) Then
MsgBox "No records to validate.Please provide test data in Test Data SpreadSheet"
Else
For RecordId = 3 To TestDataRowCount
RefreshResultSheet
'Source File row count
SrceFile = Worksheets("TestData").Range("D" & RecordId).Value
Set sourcewb = Workbooks.Open(SrceFile)
With sourcewb.Worksheets(1)
SourceRowCount = .Cells(.Rows.Count, "A").End(xlUp).row
sourcewb.Close
End With
'Target File row count
TrgtFile = Worksheets("TestData").Range("E" & RecordId).Value
Set targetwb = Workbooks.Open(TrgtFile)
With targetwb.Worksheets(1)
TargetRowCount = .Cells(.Rows.Count, "A").End(xlUp).row
targetwb.Close
End With
' Set Row Count Result Test data value
TitleId = TitleId + 3
Worksheets("Result").Range("A" & TitleId).Value = Worksheets("TestData").Range("A" & RecordId).Value
'Compare Source and Target Row count
Resultid = TitleId + 1
Worksheets("Result").Range("A" & Resultid).Value = "Source and Target record Count"
If (SourceRowCount = TargetRowCount) Then
Worksheets("Result").Range("B" & Resultid).Value = "Passed"
Worksheets("Result").Range("C" & Resultid).Value = "Source Row Count: " & SourceRowCount & " & " & " Target Row Count: " & TargetRowCount
TestPassCount = TestPassCount + 1
Else
Worksheets("Result").Range("B" & Resultid).Value = "Failed"
Worksheets("Result").Range("C" & Resultid).Value = "Source Row Count: " & SourceRowCount & " & " & " Target Row Count: " & TargetRowCount
TestFailCount = TestFailCount + 1
End If
'For comparison of two files
FileName1 = Worksheets("TestData").Range("D" & RecordId).Value
FileName2 = Worksheets("TestData").Range("E" & RecordId).Value
Set myWorkbook1 = Workbooks.Open(FileName1)
Set myWorkbook2 = Workbooks.Open(FileName2)
Difference = Compare2WorkSheets(myWorkbook1.Worksheets("Sheet1"), myWorkbook2.Worksheets("Sheet1"))
myWorkbook1.Close
myWorkbook2.Close
'MsgBox Difference
'Set Result of data validation in result sheet
Resultid = Resultid + 1
Worksheets("Result").Activate
Worksheets("Result").Range("A" & Resultid).Value = "Data validation of source and target File"
If Difference > 0 Then
Worksheets("Result").Range("B" & Resultid).Value = "Failed"
Worksheets("Result").Range("C" & Resultid).Value = Difference & " cells contains different data!"
TestFailCount = TestFailCount + 1
Else
Worksheets("Result").Range("B" & Resultid).Value = "Passed"
Worksheets("Result").Range("C" & Resultid).Value = Difference & " cells contains different data!"
TestPassCount = TestPassCount + 1
End If
Next RecordId
End If
UpdateTestExecData TestPassCount, TestFailCount
End Sub
Sub RefreshResultSheet()
Worksheets("Result").Activate
Worksheets("Result").Range("B1:B4").Select
Selection.ClearContents
Worksheets("Result").Range("D1:D4").Select
Selection.ClearContents
Worksheets("Result").Range("B1").Value = Worksheets("Instructions").Range("D3").Value
Worksheets("Result").Range("B2").Value = Worksheets("Instructions").Range("D4").Value
Worksheets("Result").Range("B3").Value = Worksheets("Instructions").Range("D6").Value
Worksheets("Result").Range("B4").Value = Worksheets("Instructions").Range("D5").Value
End Sub
Sub UpdateTestExecData(TestPassCount As Integer, TestFailCount As Integer)
Worksheets("Result").Range("D1").Value = TestPassCount + TestFailCount
Worksheets("Result").Range("D2").Value = TestPassCount
Worksheets("Result").Range("D3").Value = TestFailCount
Worksheets("Result").Range("D4").Value = ((TestPassCount / (TestPassCount + TestFailCount)))
End Sub
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.
Please help me out....I have been trying to solve this for a while now.
Raw file (Excel):
Master File (Excel):
Sheet names in Master File:
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" & j).Value
On Error GoTo new_tab
Workbooks(NewFN).Worksheets("Counts").Range("A" & j & ":I" & j).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" & j & ":I" & j).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
The first potential problem I can see here is in the For j = 2 To lrow loop you keep referring to the variable i instead of what I assume is supposed to be j. I can't see that the i variable has been initialized anywhere?