First post so please excuse any poor etiquette.
I am writing a VBA which produces an information pack for our customers to use. This pack is built to be dynamic based on certain user selections - for example FAQ pages will be specific to selections made by the user. I have built each module to add the relevant sheet names to a contents sheet as it runs. At the end, I pick up this list of sheets, select them and produce a PDF.
What I am trying to do is hide all of the other sheets other than the ones that are selected - I can do this by calling them specifically by name, or by adding "zzz" to the end of sheet names which are pure reference sheets, but I am hoping there is a better way.
The code I want would do this:
Select all of the sheets which have been added to the contents page and create an array (this already works)
Produce the PDF for the selected sheets (this also works)
Hide any sheet which is not in the array (this is what I am struggling with)
Code for producing the PDF is below - note that due to some ill-planned naming, "Contents Array" is a named range on the contents sheet, and "ContentsList" is the VBA array:
For Each cell In wsContents.Range("ContentsArray")
ContentsList(j) = cell.Value
wb1.Sheets(cell.Value).Select
j = j + 1
Next 'cell
wb1.Sheets(ContentsList()).Select
FileName = wsControl.Range("CustomerName") & " Pack " & Format(wsControl.Range("ReportDate"), "dd-mm-yyyy")
PDFFilePath = wb1.Path & "/AutoGenerated Packs/" & FileName & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=PDFFilePath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True
First, you can set your array to the range in one go:
ContentsList = wsContents.Range("ContentsArray").Value
You will then need to loop through your array for each sheet in your workbook to check if it exists... Something like the below (if you use the same method for the array as you already have, else you will need another way to determine j (the number of elements in your array)):
Dim ws As Worksheet
Dim i As Long
For Each ws In Thisworkbook.Worksheets
For i = 1 To j
If ws.Name = ContentsList(i) Then
'if found exit for as we do not want to hide
Exit For
End If
'if not found then hide
If i = j Then
ws.Visible = xlSheetHidden
End If
Next j
Next ws
Hope this helps!
Related
I have a unit matrix that illustrates work items for an apartment complex. It expands to 5 floors and has more work items than just the kitchen scope. My end goal is to have a sheet for each unit, listing the specific items needed for that unit. It would be very helpful once construction begins.
I want to do 2 things. 1 - Create new sheets for each unit (C5:C124) using the template. 2 - Copy over the information based on what is marked with an "X"
I know how to create a macros that will create blank sheets from the number of units I have. I'm stuck on integrating the template.
Thank you for reading.
Unit Scope Matrix
Template
Edit 1:
Here is my new code that can take a range of room#s and create new sheets from it. Now I would like to copy and paste the the row next the the according room# cell and paste in the appropriate sheet.
Sub CreateSheets()
Dim rng As Range
Dim cell As Range
On Error GoTo Errorhandling
'Creates popup box asking for the room numbers
Set rng = Application.InputBox(Prompt:="Select cell range:", _
Title:="Create sheets", _
Default:=Selection.Address, Type:=8)
For Each cell In rng
'Check if cell is not empty
If cell <> "" Then
'Insert worksheet and name the worksheet based on cell value
Sheets("Template").Copy After:=Sheets("Unit Types")
'Name new sheet based off two cells on Bid Summary List Cells (Bi and Di)
ActiveSheet.Name = "UNIT-" & cell
'This is where I think I should add the copy/paste lines... but I don't know how.
'Copy unit# row and paste in correct worksheet
'Range("XX:XX").Copy Range("XX:XX")
End If
'Continue with next cell in cell range
Next cell
'Go here if an error occurs
Errorhandling:
'Stop macro
End Sub
The code to copy the template and rename it is easy enough to make. Start recording, do one manually, stop recording, then press Alt-F11 to see how it's done, then steal from that to make your own function.
I suspect you'll end up with something that looks like
Function NewSheet(nm as String) as Worksheet
Dim template As Worksheet
set template = ActiveWorkbook.sheets('template')
set NewSheet = template.copy(ActiveWorkbook)
NewSheet.name = nm // change the tab name
NewSheet range('B1') = nm // add to the sheet as well
End Function
(warning: syntax and method names might unintentionally be wrong, this is intended to give you a head start, not do it for you)
and then you'll need to write a macro that loops through column C and calls your function. In this case you can ignore that NewSheet returns a new Worksheet object, but this way provides flexible code for future needs. Also, by isolating what you need to do to make a new worksheet as its own function that's called multiple times, It's easier to reason through and test, and the looping code that calls it is much easier to read as well.
Try searching for "Excel VBA looping examples" to get a head start on looping if you are unfamiliar.
I have a macro that generates a copy of an excel under a new name while not overriding the original. It is used to generate a copy for all staff while protecting the original.
I am trying to create a similar file that saves a copy of the visible sheets with todays date in another sharepoint location, but my macro hits an error because the sheets I am copying contain tables.
Exact error: "cannot copy sheet that contains table" the macro fails on line "Sheets(myArray).Copy" any ideas would be greatly appreciated :-)
Dim myArray() As Variant
Dim i As Integer
Dim j As Integer
j = 0
For i = 1 To Sheets.Count
If Sheets(i).Visible = True Then
ReDim Preserve myArray(j)
myArray(j) = i
j = j + 1
End If
Next i
Sheets(myArray).Select
Sheets(myArray).Copy
ActiveWorkbook.SaveAs Filename:="Low Level" & newdate & ".xlsx",
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Save
ActiveWindow.Close
OK, according to this article the limitation is only that you cannot copy multiple sheets with tables at the same time using Sheets(..).Copy.
That is, you can copy one sheet with a table at a time with Sheets(..).Copy or alternatively, you can copy multiple sheets with tables using some other methods such as ActiveWindow.SelectedSheets.Copy.
(I have not tested this, so you will have to confirm for yourself)
Guy, I am beginner for VBA language, and I have a question to stuck on it.
How to make a macro script to check if ANY rows of column B is input word of "C" AND ANY rows of column C is empty, then it will trigger to highlight this row with color and prompt up the message box to remind user to correct it.
Also, the column D is using the formula and cell by cell method to check the above requirement.
=IF(ISBLANK(B4),"",IF(OR(B4="C",B4="O"),IF(AND(B4="C", ISBLANK(C4)),"WARNING: Case Closed! Please Write Down Resolution!",""),"ERROR: Invalid Value - Status! Please Input The Right Value!"))
For example, the row 4 meet up requirement and affected.
Is there way to do so?
Please help. Thanks.
UPDATE:Thanks Variatus!
When I save the file, it prompt up this message box. What can I do? Thanks.
Macro Screen
Error
Under normal circumstances you would be asked to show more of an own effort before receiving help on this forum, including from me. But apparently circumstances aren't normal. So, here we go. Paste this procedure to a standard code module (it's name would be a variation of Module1 by default).
Option Explicit
Sub MarkErrors()
' 283
Dim Spike() As String
Dim i As Long ' index of Spike
Dim Rl As Long ' last used row
Dim R As Long ' loop counter: rows
Application.ScreenUpdating = False
With Sheet1 ' this is the sheet's CodeName (change to suit)
.UsedRange.Interior.Pattern = xlNone ' remove all existing highlights
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
ReDim Spike(1 To Rl)
For R = 2 To Rl
If Trim(.Cells(R, "B").Value) = "C" Then
If IsEmpty(.Cells(R, "C")) Then
.Range(.Cells(R, "A"), .Cells(R, "D")).Interior.Color = vbYellow
i = i + 1
Spike(i) = "Row " & R
End If
End If
Next R
End With
Application.ScreenUpdating = True
If i Then
ReDim Preserve Spike(1 To i)
MsgBox "Status errors were found in the following entries:-" & vbCr & _
Join(Spike, "," & vbCr), vbInformation, "Corrections required"
End If
End Sub
Pay attention to the specified worksheet Sheet1. This is a CodeName, and it is a default. Excel will create a sheet by that name when you create a workbook. The CodeName doesn't change when the user changes the tab name but you can change it in the VB Editor. It's the (Name) property of the worksheet.
Install the procedure below in the code sheet of Sheet1 (not a standard code module and therefore not the same as where you installed the above code. This module is created by Excel for each sheet in every workbook. Use the existing one.
Private Sub Worksheet_Activate()
' 283
MarkErrors
End Sub
This is an event procedure. It will run automatically whenever Sheet1 is activated (selected). So, under normal circumstances you shouldn't ever need to run the first procedure manually. But I've already talked about circumstances. They aren't always normal. :-)
From the below Image I want to compare Second Workbook(Records.xlsm) with First Workbook(HandBook.xlsm)
I want to check if Department ID and Course ID Combination is valid by comparing it with the first workbook(HandBook.xlsm) and highlight in yellow if the combination doesn't exist.
But When i tried to write the code,I was able to check only the first record, i.e in the below example Dept Id 3000 has three different course ID but when I try to compare it is validating only with the first record occurrence 3000-123 , if I try to put any other combination 3000-124 or 3000-125 it is highlighted as error which should not be the case.
Columns("B:B").Select
Range("B1").Select
ActiveCell.FormulaR1C1 = "=IF(OR(NOT(ISERROR(MATCH(RC[2],INDEX('[HandBook.xlsm]Dept-Course'!C2,MATCH(RC[1],'[HandBook.xlsm]Dept-Course'!C1,0),0),0)))),"""",""ERROR"")"
Selection.Copy
Range("A1").Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlDown).Select
Selection.End(xlUp).Select
ActiveCell.Offset(0, 1).Select
If ActiveCell.Row > 2 Then
Range(Selection, Selection.End(xlUp)).Select
End If
ActiveSheet.Paste
I prepared 2 solutions for you. The first doesn't require VBA. But it needs a helper column and this is why I think you won't like it. However, you may like to try. In the helper column enter this formula.
=SUMPRODUCT(('[082 STO 200829 Records.xlsm]Records'!$A:$A=C2)*('[082 STO 200829 Records.xlsm]Records'!$B:$B=D2))
The referenced workbook must be open at the time of writing the formula. After that it can be closed. The formula will return either 1 or 0 depending upon whether a match was found in the referenced file. Observe that column A:A in the referenced sheet holds data similar to C2 and B:B has that same relationship with D2. The result you can use to highlight cells using conditional formatting.
Select the first pair of Department/Course IDs on your Handbook sheet.
Create a New Rule to conditionally format these cells depending upon a formula. (In my worksheet that was C2:D2)
Insert this formula: =$E2=0 (In my example E:E is the helper column)
Choose the highlight you like.
Before you close the dialog correct the range to which the formula applies. The field originally shows just the selected cells. Extend the range all the way down your sheet. You might also have selected all to begin with but I prefer this way if the range is big and you don't want to drag the selection forever.
I prepared a VBA solution as well but I didn't much like that, either. It's a lot of code compared with your humble beginnings and that is before I got around to dealing with the screen flicker as the referenced file is opened and closed. I'm not sure I shall be able to deal with that entirely.
Therefore I abandoned that attempt when it was nearly done and now work on a solution that doesn't open the referenced workbook. I shall come back to publish it here later today.
Meanwhile I think the above solution has much to speak for it by way of simplicity. Bear in mind that you can have the helper column anywhere on the sheet, and you can hide it as well.
There are two parts of the code for this solution which must be placed exactly where they belong. The first part is an event procedure. It fires automatically when the user changes either the Department or the Course in the Handbook. This Change event will not be noticed anywhere in your workbook except in the worksheet concerned. Therefore the code must be in that tab's code module. That is an existing module, set up by Excel for this purpose.
The second part of the code deals with the external workbook which I identified as "Records.xlsm". Therefore I prefer it to be in a standard code module. That is a module you set up yourself. The default name will be Module1 but I (with the support of all but the most new newbies at programming) recommend to give a descriptive name. In my copy of the workbook I named it ADO_Conn for the ADODB Connection it contains.
In addition to the ADODB connection this part also contains various parameters which you may adjust to match your needs and liking. They take the shape of enumerations which offer an efficient way to allot names to numeric constants. I placed them here because some of them are used in both parts of the code. Their point is to let you make the code work differently without digging into the code itself. You just twiddle the knobs, as it were.
If you followed me thus far you may have noticed that there is no code for you to press a button or F5 so that it runs. The ADODB connection is called by the event procedure and the event procedure is triggered by the changes the user makes on the worksheet. The functionality is simple. When the user makes a change the macro looks for the combination of Department and Course and marks the cells if it isn't found. If the user thereupon changes the entry the process is repeated and the highlight may be removed. However, no change is triggered by a subsequent change in the Records. Such changes should be driven by change events in the Records workbook.
The more automation you want the more precise must be the setup. Start by copying part 2, here following, to a standard code module called ADO_Conn (if you like). Observe that the name avoids a space by substituting it with an underscore. This rule will also apply to the names of the two columns in Records that will be accessed. I renamed them as "Dept_ID" and "Course_ID". You can use different names, shift the columns to other locations, but you may not include any blanks in these names, nor should you change their sequence in the one place in the code where they are mentioned. If the names in the code differ from those in the workbook the workbook will still work but the code won't. Here is part 2.
Option Explicit
Enum Nwt ' worksheet Target ("Handbook" = ThisWorkbook)
' 082
NwtFirstDataRow = 2 ' change to suit
NwtDept = 3 ' Columns: 3 = C
NwtCourse ' if no value is assigned, [preceding + 1]
End Enum
Enum Nct ' search criteria: TriggerRng()
' 082
NctDept = 1 ' do not change (!!)
NctCourse
End Enum
Function HasMatch(Crits As Variant, _
SrcFile As String, _
SrcTab As String, _
SrcClms As String) As Boolean
' 082
Dim ConSpec As String
Dim Conn As Object ' late-bound ADODB.Connection
Dim Rs As Object ' late-bound ADODB.Recordset
Dim Query As String ' SQL query
Dim Sp() As String ' array of Clms
On Error GoTo ErrExit
' Create the record set and ADODB connection
Set Rs = CreateObject("ADODB.Recordset")
Set Conn = CreateObject("ADODB.Connection")
With Conn
.Provider = "Microsoft.ACE.OLEDB.12.0"
.ConnectionString = "Data Source=" & SrcFile & ";" & _
"Extended Properties=""Excel 12.0;" & _
"HDR=Yes;" & _
"IMEX=1"";"
.Open
End With
' create the SQL query string
Sp = Split("," & SrcClms, ",") ' first column index = 1
Query = "SELECT " & Sp(NctDept) & _
" FROM [" & SrcTab$ & "$]" & _
" WHERE " & Sp(NctDept) & " = " & Crits(1, NctDept) & _
" AND " & Sp(NctCourse) & " = " & Crits(1, NctCourse) & ";"
Rs.Open Query, Conn, 0, 1, 1 ' execute the query
' evaluate the retrieved recordset
HasMatch = Rs.EOF
ErrExit:
If Err Then
MsgBox "An error occurred during data retrieval:-" & vbCr & _
Err.Description, _
vbExclamation, "Error No. " & Err.Number
End If
Err.Clear
End Function
There are 2 sets of Department/Course ID numbers. The columns used in the Handbook sheet and an ID for each that the program itself uses. You can move the columns to where you want them. They don't have to stay together but I think the Department column must stay to the left of the Course column. Just change the numbers assigned to the names and the program will find them. You can also change the FirstDataRow for the Handbook sheet. But the the Records sheet only one header row is allowed - fixed, therefore not adjustable.
Here is the first part of the code. Paste it to the code module of the worksheet in Handbook where you want your entries checked.
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
' 082
' name the source workbook with its complete path (change to match your facts)
Const SrcPath As String = "D:\PVT Archive\Class 1\1-2020 (Jan 2022)\" ' end on \
Const SrcFile As String = "082 STO 200829 Records.xlsm"
Const SrcTab As String = "Records"
' match the column names in the workbook with the names used here.
' If they are changed assign names without spaces in them and
' maintain their logical sequence.
Const SrcClms As String = "Dept_ID,Course_ID"
Dim Matched As Boolean ' apply no highlight if True
Dim TriggerRng As Range ' the range that triggers action
Dim Crits As Variant ' search criteria
' don't react to changes in more than one cell
If Target.CountLarge > 1 Then Exit Sub
Set TriggerRng = Range(Cells(NwtFirstDataRow, NwtDept), _
Cells(Rows.Count, NwtDept).End(xlUp))
Set TriggerRng = Application.Union(TriggerRng, TriggerRng.Offset(0, NwtCourse - NwtDept))
If Not Intersect(Target, TriggerRng) Is Nothing Then
With Target
Set TriggerRng = Application.Union(Cells(.Row, NwtDept), _
Cells(.Row, NwtCourse))
Crits = TriggerRng.Value
If WorksheetFunction.CountA(TriggerRng) < 2 Then Exit Sub
End With
If Dir(SrcPath & SrcFile) = "" Then
' check if referenced workbook exists at the specified location
MsgBox "The workbook to be referenced" & vbCr & _
SrcFile & vbCr & "can't be found at" & vbCr & _
SrcPath & ".", _
vbInformation, "Data source not accessible"
Exit Sub
End If
With TriggerRng
If HasMatch(Crits, SrcPath & SrcFile, SrcTab, SrcClms) Then
.Interior.Color = vbYellow
Else
.Interior.Pattern = xlNone
End If
End With
End If
End Sub
There are 4 constants to be set by you. This must be done very precisely. You may also like to review the text of the messages, and I shall not mind if you improve them to better suit your needs. The rest of the code is intended to stay untouched. Whatever modifications you want must be done by using the parameters, unless you find flaws in the functionality, which I hope you will not.
SrcPath holds the path to the workbook Records. It must end on a backslash "". SrcFile holds the name of that file. This program doesn't mind if it's open or closed. SrcTab holds the name of the worksheet. I suspect that having a space in it might cause a problem. So, better avoid one. Finally, SrcClms gives the names of the column captions of the two columns in Records that we are concerned with here. Keep them aligned with what they really are, keep them free from blanks and keep their sequence aligned with the Enum Nct. Mind that ADO (ActiveX Data Object, btw) doesn't allow you to have more than 1 header row in the Records sheet. Not that it should make any difference in this particular application if there were more, unless the header rows contain potential matches. However, avoid having merged cells on that sheet anywhere.
I'm just learning how to do VBA in excell and I need some help. I have been searching this site but have not found an example that I could tweak that solves my needs (or at least what I could understand). I am trying to make a button that archives data. I have 2 sheets where one is for user input and the other is the archived location. I would like to have excell take the value in column C and past it in the matching location in sheet 2 based on the valves of sheet 1's values in column A and B.
Sheet 1
A _______ B______C (user inputed value)
Item 1 ___Date ___ 5
Item 2 ___Date ___ 8
Item 3 ___Date ___ 2
Sheet 2 (archive sheet)
A ______ B _________ C _______ D
_______Item 1 ___ Item 2 ____ Item 3
Date
Date
Date
I was using a method of just copying the sheet 1 data on a 3rd sheet and running a vlookup but if the user archived the same date twice it would only get the value of the most recent archive. Im not sure how loops work but what I found on other peoples requests I think something like that may be helpful.
Any insight would be most appreciated.
If you do not know how loops work, you must learn the basics of Excel VBA. You cannot hope to stitch together bits of code gathered from the internet without some understanding of VBA.
Search for "Excel VBA Tutorial". You will get many hits of which many will be for free online tutorials. These tutorials differ in approach so try a few to see which best matches your learning style. Alternatively, visit a good bookshop or library where you will find a selection of Excel VBA Primers. I suggest a library so you can take a few books home for a try before purchasing your favourite.
There are many holes in your specification. Perhaps you have a complete specification which you have not documented here. If you have a complete specification, please do not add it to your question. For sites like this, you need small focused questions.
Two design questions I have spotted are:
Why fill the Date column with =TODAY()? If the archive macro is not run at the end of the day, Excel will have changed the date when the macro is run the next day. Either fill the column with the date value or use the nearest VBA equivalent function which is Now().
You imply the user might enter a count for Item A and then enter another count later in the day. The archive sheet is to hold the total of those two counts. How is this handled? You could have two or more rows for Item A. The user could run the archive macro before entering a new value in the Item A row. You could use a Worksheet Change event to automatically archive the value after the user has entered it.
You need to fully specify what the macro is going to do and how it is going to be used before trying to code it. Below I have provided two alternative macros that achieve what I believe is the first step of your requirement: locate valid rows in the data entry worksheet and extract the values ready for achiving.
I suggest you study basic Excel VBA first. That should give you enough knowledge to understand my macros even though the second macro uses non-basic statements. Come back with questions as necessary but please run and try to understand the macros before asking these questions.
Demo1
I created a worksheet "Data Entry" and filled it with data that matches my understanding of your worksheet "Sheet1". Please do not use the default worksheet names because it gets very confusing. Replace my name with whatever you choose.
The macro Demo1 outputs the values from valid rows to the Immediate Window. Writing to the Immediate Window is a convenient way of testing small blocks of code as they are written.
I have documented what the code does but not the VBA statements. Once you know a statement exists, it is usually easy to look it up.
Option Explicit
Sub Demo1()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim ItemCrnt As String
Dim RowCrnt As Long
Dim RowLast As Long
With Worksheets("Data Entry")
' This sets RowLast to the last used row in column "C" or sets it to 1 if no
' row is used. It is the VBA equivalent of positioning the cursor to the
' bottom of column C and clicking Ctrl+Up
RowLast = .Cells(Rows.Count, "C").End(xlUp).Row
' I have assumed the first data row is 2
For RowCrnt = 2 To RowLast
' I have allowed for column C being empty. I assume such rows are
' to be ignored. I also ignore rows with invalid values in columns
' B or C.
If .Cells(RowCrnt, "C").Value <> "" And _
IsNumeric(.Cells(RowCrnt, "C").Value) And _
IsDate(.Cells(RowCrnt, "B").Value) Then
' Extract the validated values to variables ready for the next stage
' of processing.
ItemCrnt = .Cells(RowCrnt, "A").Value
DateCrnt = .Cells(RowCrnt, "B").Value
CountCrnt = .Cells(RowCrnt, "C").Value
' Output row values to Immediate Window
Debug.Print RowCrnt & " " & ItemCrnt & " " & _
Format(DateCrnt, "dmmmyy") & " " & CountCrnt
End If
Next
End With
End Sub
Demo2
Macro Demo2 achieves the same as macro Demo1 but in a different way.
Demo1 accessed the cells within the worksheet individually. Demo2 copies the entire
worksheet to a Variant which can then be accessed as a 2D array. This is much faster that individual cell access and is usually more convenient if you only want the cell values.
Demo1 output values to the Immediate Window. This is very convenient for small volumes of output but early lines will be lost for larger volumes. Demo2 creates a file within the same folder as the workbook and writes the output to that file so nothing will be lost.
Sub Demo2()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim FileOutNum As Long
Dim ItemCrnt As String
Dim RowCrnt As Long
Dim RowLast As Long
Dim SheetValue As Variant
FileOutNum = FreeFile
Open ActiveWorkbook.Path & "\Demo2.txt" For Output As #FileOutNum
With Worksheets("Data Entry")
' This statement converts Variant SheetValue to an appropriately sized
' two-dimensional array and copies the values from the entire used
' range of the worksheet to it.
SheetValue = .UsedRange.Value
' Standard practice for 2D arrays is to have the first dimension for
' columns and the second for rows. For arrays copied from or to
' worksheets, the first dimension is for rows and the second is for
' columns. This can be confusing but means that array elements are
' accessed as SheetValue(Row, Column) which matches Cells(Row, Column).
' Note that the lower bounds for both dimensions are always one. If the
' range copied from the worksheet starts at Cell A1, row and column
' numbers for the array will match those of the worksheet.
End With
For RowCrnt = 2 To UBound(SheetValue, 1)
' I have allowed for column 3 (= "C") being empty. I assume such rows
' are to be ignored. I also ignore rows with invalid values in columns
' 2 (= "B") or 3.
If SheetValue(RowCrnt, 3) <> "" And _
IsNumeric(SheetValue(RowCrnt, 3)) And _
IsDate(SheetValue(RowCrnt, 2)) Then
ItemCrnt = SheetValue(RowCrnt, 1)
DateCrnt = SheetValue(RowCrnt, 2)
CountCrnt = SheetValue(RowCrnt, 3)
' Output row values to file
Print #FileOutNum, RowCrnt & " " & ItemCrnt & " " & _
Format(DateCrnt, "dmmmyy") & " " & CountCrnt
End If
Next
Close #FileOutNum
End Sub
Edit New section in response to supplementary question.
As you have discovered there is no way of "printing" to a worksheet but it is easy to write to individual cells. I have used a diagnostic worksheet but I normally consider this technique more trouble than it is worth. Output to a file is easier to add and easier to delete and it does not interfere with the code.
The code below is in the correct order but I have added explanations between blocks.
Dim RowDiagCrnt As Long
The above statement is not within a subroutine which makes is a gloabl variable that can be accessed from any routine. If there are several routines that need to output diagnostic information, it is easier to use a global variable for the row number than pass it as a parameter from the parent routine.
I have a system for naming variables, "Row" means this is a row. "Diag" identifies the worksheet". "Crnt" identifies this as the current row number. In Demo1, I had RowCrnt because I only had one worksheet. You may not like my system. Fine, develop your own. Having a system means I can look at a macro I wrote years ago and know what all the variables are. This makes maintenance much, much easier.
Sub Demo3()
Dim CountCrnt As Long
Dim DateCrnt As Date
Dim ItemCrnt As String
Dim RowDiagCrnt As Long
Dim RowEntryCrnt As Long
Dim RowEntryLast As Long
Dim ValidRow As Boolean
Dim WkshtDiag As Worksheet
Dim WkshtEntry As Worksheet
I now have two worksheets and I will have to switch between them. I do not like multiple uses of Worksheets("Xxxxx") because I might change "Xxxxx". A reference avoids multiple uses of the name and is faster.
Set WkshtEntry = Worksheets("Data Entry")
Set WkshtDiag = Worksheets("Diagnostics")
' Delete existing contents of diagnostic worksheet and create header row
With WkshtDiag
.Cells.EntireRow.Delete
.Cells(1, "A").Value = "Row"
.Cells(1, "B").Value = "Item"
.Cells(1, "C").Value = "Date"
.Cells(1, "D").Value = "Count"
End With
RowDiagCrnt = 2
With WkshtEntry
RowEntryLast = .Cells(Rows.Count, "C").End(xlUp).Row
End With
For RowEntryCrnt = 2 To RowEntryLast
I must keep the access to the two worksheet separate if I want to use With statements. I have used a boolean to handle this problem.
With WkshtEntry
If .Cells(RowEntryCrnt, "C").Value <> "" And _
IsNumeric(.Cells(RowEntryCrnt, "C").Value) And _
IsDate(.Cells(RowEntryCrnt, "B").Value) Then
ItemCrnt = .Cells(RowEntryCrnt, "A").Value
DateCrnt = .Cells(RowEntryCrnt, "B").Value
CountCrnt = .Cells(RowEntryCrnt, "C").Value
ValidRow = True
Else
ValidRow = False
End If
End With
If ValidRow Then
With WkshtDiag
' Output row values to Diagnostic worksheet
.Cells(RowDiagCrnt, "A").Value = RowEntryCrnt
.Cells(RowDiagCrnt, "B").Value = ItemCrnt
With .Cells(RowDiagCrnt, "C")
.Value = DateCrnt
.NumberFormat = "dmmmyy"
End With
.Cells(RowDiagCrnt, "D").Value = CountCrnt
RowDiagCrnt = RowDiagCrnt + 1
End With
End If
Next
' Set columns to appropriate width for contents
With WkshtDiag
.Columns.AutoFit
End With
End Sub
I hope you can see why the reasons for all the changes I made to Demo1 to create Demo3. Having a second worksheet that is not required for the final solution adds complexity that I normally prefer to avoid.