I have code creates new sheets naming them by their project numbers (e.g., PRJ_123456, PRJ_654654). The first chunk of code here works wonderfully. My problem is that some projects have 5 digits, instead of 6. In the second piece of code, when I pull the project number it causes problems for things I try to do. I have tried many ways of retaining the leading zero for five digit project numbers, but it does not do so when creating the spreadsheet.
Sub Pop()
Sheets("Project_Main").Select
Range("C2").Select
Do Until IsEmpty(ActiveCell)
If (Sheets("Program").Range("C3").Value) = ActiveCell.Value Then
Dim PRJNumber
PRJNumber = ActiveCell.Offset(0, 2)
'PRJNumber.NumberFormat = "000000"
MsgBox (PRJNumber)
Sheets("Template_PRJ").Select
Sheets("Template_PRJ").Copy Before:=Sheets(2)
Sheets("Template_PRJ (2)").Select
Dim SheetPRJName
SheetPRJName = "PRJ_" & PRJNumber
Sheets("Template_PRJ (2)").Name = SheetPRJName
end if
loop
end sub
This is what I try to do later
For Each wks In ActiveWorkbook.Worksheets
If ((Left(wks.Name, 3) = "PRJ")) Then
PRJNumber = Right(wks.Name, 6)
'MsgBox (prjNumber)
....
Make sure to DIM your PRJNumber variable as a string since that's what we are dealing with.
When the value comes through, if it's 5 characters instead of 6 append a 0. After you assign PRJNumber use: If len(PRJNumber) = 5 then PRJNumber = "0" & PRJNumber
Since you are appending "PRJ_" on the front of it for the sheet name, then should be good to go from here.
Related
I've got a workbook containing a Summary sheet and 200 numbered sheets that the user fills in one after the other.
The following macro checks about 125 cell values on every numbered sheet, and fills in the Summary, one line per numbered sheet.
If a numbered sheet hasnt been used yet, the macro fills in every column from column D to column DV with the minus sign "-" and goes on to check every numbered sheet one after the other till there's no more to check.
Is there a way to set it so that if an arbitrary number (let's say 10 lines) of the newly generated lines contain only the minus sign "-" from D to DV (Iw,4 to Iw, 126), then the macro would reach its end as it means all the remaining numbered sheets aren't used yet?
Sub SummaryMacro()
Dim Sh As Worksheet
Range("B2:L1000").ClearContents
Iw = 2 ' Index Write
For Each Sh In ActiveWorkbook.Sheets
If Sh.Name = "Summary" Then GoTo EndConsolidation
Cells(Iw, 1).Select
With Selection
.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:="'" & Sh.Name & "'" & "!" & "A1", TextToDisplay:="Go to"
End With
Cells(Iw, 2) = Sh.Name
If Sh.Range("D8") = "" Then
Cells(Iw, 3) = "-"
Else
Cells(Iw, 3) = Sh.Range("D8")
End If
'Here the rest of the process (Iw, 4 till Iw, 125)
'The process also includes a few variations:
'Something like 20 of those with various text
If Sh.CheckBoxes("Check Box 1").Value = 1 Then Cells(Iw, 40) = "Declared" Else Cells(Iw, 40) = "-"
'Something like 30 of those with various text
If Sh.Range("H33") = "Issued" Then
Cells(Iw, 42) = "-"
Else
Cells(Iw, 42) = Sh.Range("H33")
End If
'But all in all they are mostly like that
If Sh.Range("C134") = "" Then
Cells(Iw, 126) = "-"
Else
Cells(Iw, 126) = Sh.Range("C134")
End If
Iw = Iw + 1
EndConsolidation:
Next Sh
End Sub
Try adding this code to your For loop at the end:
If (WorksheetFunction.CountIf(Range("D" & Iw & ":DV" & Iw), "-") = 123) Then
Cntr = Cntr + 1 'Blank sheet found
Else
Cntr = 0 'Not blank - Restart counter
End If
If (Cntr = 10) Then Exit For
This counts the number of - in your row and if it equals 123 (D-DV) then it increments the counter otherwise it clears the counter. When Cntr reaches 10 it exits the loop.
HTH
Add this code before your For loop ends
Dim counter As Integer
Dim previousRowBlank As Boolean
counter = 0
previousRowBlank = True
'count if all the 123 cells contain - string
If (WorksheetFunction.CountIf(Sheets("Summary").Range("D" & Iw & ":DV" & Iw), "-") = 123) Then
If (counter = 0) Then
counter = counter + 1
previousRowBlank = True
Else
If (previousRowBlank = True) Then
counter = counter + 1
End If
End If
Else
previousRowBlank = False
counter = 0
End If
'assuming you want to exit when 10 consecutive rows are blank
If (counter = 10) Then
Exit Sub
End If
When I have something like this I Dim a Boolean variable (perhaps call it isPopulated) which only gets switched to true when one of the cells has a value to act on. Then for your case after 10 (or however many you choose) lines, insert an If isPopulated = False Then Exit For to skip the remaining sheets.
EDIT; another idea I just had for you - if all the cells you're checking are supposed to have numeric values then you could use the below;
If Not WorksheetFunction.Concat(Range("D8"), Range("C134"), etc) Like "*#*" Then
'Code here to skip this and remaining sheets.
Obviously you'd need to add the relevant ranges inside the concat() brackets. What that will do is join the contents of those cells together, then check the result for any numbers "*#*" (you could also check for any letters using "*?*"). That gives you a one-code-line answer to the basic question 'is this sheet populated or not'.
I'm sure it's a bad idea to terminate the macro prematurely, based on such an imprecise criterion as the number of "empty" sheets in series. If data starts again on the 11th, 15th or 30th sheet, then you will not process it, you will lose it.
Your macro is not very complex, it shouldn't take longer than a few seconds. For modern Excel, 25K cells are very few
Your code can be shortened a little, simplified. After all, you know all the addresses of the cells that you need to check on each sheet, you enter them in the macro code sequentially, right? Write them on one line separated by commas and put them in a constant.
After that, the whole code will become much shorter:
Sub SummaryMacro()
Const REQUIRED_CELLS_ADDRESS As String = "D8,...<all other source cells>...,B6"
Const SUM_SHEETNAME As String = "Summary"
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim rCell As Range
Dim oTargetCell As Range
Dim oSumCell As Range
Dim aAddress As Variant
Dim i As Integer
aAddress = Split(REQUIRED_CELLS_ADDRESS, ",")
Set wsSum = ActiveWorkbook.Worksheets(SUM_SHEETNAME)
wsSum.UsedRange.Offset(1, 0).ClearContents
Set oTargetCell = wsSum.Range("A1")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> SUM_SHEETNAME Then
Set oTargetCell = oTargetCell.Offset(1, 0)
wsSum.Hyperlinks.Add Anchor:=oTargetCell, Address:="", SubAddress:="'" & ws.Name & "'" & "!" & "A1", TextToDisplay:="Go to"
oTargetCell.Resize(1, 123).Value = "-"
Set oSumCell = oTargetCell.Offset(0, 1)
oSumCell.Value = ws.Name
For i = LBound(aAddress) To UBound(aAddress)
Set rCell = ws.Range(aAddress(i))
Set oSumCell = oSumCell.Offset(0, 1)
If Not IsEmpty(rCell) Then oSumCell.Value2 = rCell.Value2
Next i
End If
Next ws
End Sub
Update Everyone knows that working with an array in RAM is much faster than working with sheet cells. Therefore, the outer loop - iterating over the sheets of the book - remains the same, but we change the code inside the loop in this way:
Sub SummaryMacro()
Const SUM_SHEETNAME As String = "Summary"
Dim ws As Worksheet
Dim wsSum As Worksheet
Dim oTargetCell As Range
Dim aResData As Variant
aAddress = Split(REQUIRED_CELLS_ADDRESS, ",")
Set wsSum = ActiveWorkbook.Worksheets(SUM_SHEETNAME)
wsSum.UsedRange.Offset(1, 0).ClearContents
Set oTargetCell = wsSum.Range("A1")
For Each ws In ActiveWorkbook.Worksheets
If ws.Name <> SUM_SHEETNAME Then
Set oTargetCell = oTargetCell.Offset(1, 0)
wsSum.Hyperlinks.Add Anchor:=oTargetCell, Address:="", SubAddress:="'" & ws.Name & "'" & "!" & "A1", TextToDisplay:="Go to " & ws.Name
aResData = validateData(ws.Range("A1:L140").Value2) ' Or "D8:C134" or any other
oTargetCell.Offset(0, 1).Resize(1, UBound(aResData) + 1).Value = aResData
End If
Next ws
End Sub
The main trick is hidden in this line aResData = validateData(ws.Range("A1:L140").Value2)
We call our function and pass it as a parameter an array of cell values from the entire next sheet. Further work on analysis and processing will be carried out with the elements of this array. However, this is not the whole trick.
The validateData() function is very simple and looks like this:
Function validateData(aD As Variant) As Variant
validateData = validateValues(aD(1, 5), aD(2, 8), aD(3, 1), aD(2, 11), _
........ , _
aD(111, 3), aD(112, 8), aD(123, 9), aD(126, 10))
End Function
In other words, we select from the entire large array of aD (the name is deliberately made short, because in this function it will have to be repeated 123 times) only those values that need to be analyzed and we pass on to the next function. Despite the seeming simplicity, this is the most time-consuming part - you need to select from the sheet all cells "D8", "C134", etc. and write down their coordinates (row, column) as numbers aD(4,8), aD(3,134), etc.
Perhaps can help in this the mode R1C1 of displaying the sheet. Or some kind of helper function that will be used when preparing the code (not when executing - we agreed that we will no longer access cells for get values or for .Row and .Column properties!)
What will the validateData() function get? A long one-dimensional array aData(0 To 122) of cell values in the listed order. That is, as many values as there are cells to be filled in the Summary row for this sheet.
The last trick is the process of processing values. It would seem that we have gained nothing from all these transformations. But you claim that there are three groups of checks - for an empty value, for a boolean value (checkbox) and for text lines. This is how it is handled:
Function validateValues(ParamArray aData() As Variant) As Variant
Dim i As Variant
Dim aResult As Variant
ReDim aResult(LBound(aData) To UBound(aData))
For i = LBound(aData) To UBound(aData)
Select Case i
Case 1, 5, 7, 9 ' Checking cells empty / value
aResult(i) = IIf(aData(i) = "", "-", aData(i))
Case 4, 6, 10 ' Checking cells boolean True / "not True" (False or blank)
aResult(i) = IIf(aData(i), "Declared", "-")
Case 0, 3, 8 ' Checking cells string "Issued" / other
aResult(i) = IIf(aData(i) = "Issued", "-", aData(i))
Case 2, 91, 118 ' Checking cells string "Pending" / other
aResult(i) = IIf(aData(i) = "Issued", "-", aData(i))
Case Else ' In a real macro, this line is not needed, it will never be executed because all the cells of the array are already listed above, this is useful only for debugging while all conditions will be written
aResult(i) = "-"
Debug.Print "Cell #" & i & " not processed yet"
End Select
Next i
validateValues = aResult
End Function
And now - again, in just one call! - we write a whole row of results:
oTargetCell.Offset(0, 1).Resize(1, UBound(aResData) + 1).Value = aResData
I am sure that these tricks will reduce the time it takes to form the summary sheet many times over. Please try this and let me know if it gets better?
I have never coded in VBA before and am trying to teach myself based off Youtube videos right now which is proving difficult. I am attempting to do a for loop that deletes a row if it does not equal the Part Number, and if the part number is correct, I want the loop to do nothing and move on. I have been typing up random lists of numbers to test my code on, but when I run it, every single row is deleted (even the ones with the correct part number). Ultimately, when I run this on the real data the part number will be a combination of letters and numbers as well as a dash, so I should be storing the Part Number as a string variable correct? Any advice?
Sub CodingPrac()
Dim PartNum As String
PartNum = InputBox("Enter the Part Number", "Part Number", "Type value here")
lastrow = ThisWorkbook.Sheets(2).Cells(Rows.Count, 1).End(xlUp).Row
For i = lastrow To 1 Step -1
If Cells(i, 1).Value = "PartNum" Then
Else
ThisWorkbook.Sheets(2).Rows(i).EntireRow.Delete
End If
Next i
End Sub
Replace:
If Cells(i, 1).Value = "PartNum" Then
with:
If Cells(i, 1).Value = PartNum Then
you need the value of the variable, not a string.
EDIT#1:
Your code (as posted) would work if column A was like:
I've written the code below but I can't get past a line where I want to insert a variable number of rows. The compiler screams that it needs a "list separator or )" where there is a colon. But I can't find other ways of writing this. Please, help! =)
So, the problematic line is denoted by two stars from each end. Just above it there is a commented line that I've also tried with no success.
Also, would you be so kind and explain me what I need the following commands for (they are also found in the problematic line):Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Finally, any suggestions of how I could improve the code, s.t., experienced programmers don't faint when they read it? =)
Huge thank you in advance,
Option Explicit
Dim ws As Worksheet
Dim Blatt1, Blatt2 As String
Dim Anfangsjahr1, Anfangsjahr2 As Integer
Dim reporting_Jahr1, reporting_Jahr2 As String
Public Sub Dreiecke()
For Each ws In Worksheets
If ws.Name Like "RVA_H*" Then
If IsEmpty(Blatt1) = False Then
Blatt2 = ws.Name
Anfangsjahr2 = ws.Range("A3").Value
reporting_Jahr2 = ws.Range("A1").Value
Else
Blatt1 = ws.Name
Anfangsjahr1 = ws.Cells(3, 1).Value
reporting_Jahr1 = ws.Cells(1, 1).Value
GoTo X
End If
Else: GoTo X
End If
If reporting_Jahr1 <> reporting_Jahr2 Then
MsgBox "Dreiecke von unterschiedlichen Jahren"
Exit Sub
ElseIf reporting_Jahr1 = reporting_Jahr2 Then
If Anfangsjahr1 < Anfangsjahr2 Then
'Sheets(Blatt2).Rows(3:3+Anfangsjahr2-Anfangsjahr1).EntireRow.Insert
**Worksheets(Blatt2).Rows(3: 3 + Anfangsjahr2 - Anfangsjahr1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove**
ElseIf Anfangsjahr1 > Anfangsjahr2 Then
Worksheets(Blatt1).Rows(3:3+Anfangsjahr1-Anfangsjahr2).Insert Shift:=xlDown
ElseIf Anfangsjahr1 = Anfangsjahr2 Then GoTo X
End If
End If
X: Next ws
End Sub
I don't follow exactly what you are trying to get to here but there are some syntax issues.
Not sure if this is what you want, but it fixes the syntax. Do you rally want
Worksheets(Blatt2).Rows("3:" & 3 + Anfangsjahr2 - Anfangsjahr1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
EDIT to expand on OP's question in the comments below
The double quotes are used to enclose a string. So normally when you are referencing rows you can say .Rows("3:9").Insert This is providing the rows you want to work with as a string.
In your case you wanted to dynamically provide last row so we have
our string "3:"
transition from string to variable &
and our variables and math 3 + Anfangsjahr2 - Anfangsjahr1
To make up .Rows("3:" & 3 + Anfangsjahr2 - Anfangsjahr1).Insert
You need to place the row number in double quotation marks and then concatenate the variables to the string using an ampersand:
Worksheets(Blatt2).Rows("3:" & 3 + Anfangsjahr2 - Anfangsjahr1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Please be aware that I am working with a series of ~1000 line medical information databases. Due to the size of the databases, manual manipulation of the data is too time consuming. As such, I have attempted to learn VBA and code an Excel 2010 macro using VBA to help me accomplish parsing certain data. The desired output is to split certain characters from a provided string on each line of the database as follows:
99204 - OFFICE/OUTPATIENT VISIT, NEW
will need to be split into
Active Row Active Column = 99204 ActiveRow Active Column+3 = OFFICE/OUTPATIENT VISIT, NEW
I have researched this topic using Walkenbach's "Excel 2013: Power Programming with VBA" and a fair amount of web resources, including this awesome site, but have been unable to develop a fully-workable solution using VBA in Excel. The code for my current macro is:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
Cells(1, a + 3).Value = Trim(name(a))
Next a
End Sub
The code uses the "-" character as a delimiter to split the input string into two substrings (I have limited the output strings to 2, as there exists in some input strings multiple "-" characters). I have trimmed the second string output to remove leading spaces.
The trouble that I am having is that the output is being presented at the top of the activesheet, instead of on the activerow.
Thank you in advance for any help. I have been working on this for 2 days and although I have made some progress, I feel that I have reached an impasse. I think that the issue is somewhere in the
Cells(1, a + 3).Value = Trim(name(a))
code, specifically with "Cells()".
Thank you Conrad Frix!
Yah.. funny enough. Just after I post I have a brainstorm.. and modify the code to read:
Sub EasySplit()
Dim text As String
Dim a As Integer
Dim name As Variant
text = ActiveCell.Value
name = Split(text, "-", 2)
For a = 0 To 1
ActiveCell.Offset(0, 3 + a).Value = Trim(name(a))
Next a
End Sub
Not quite the colkumn1,column4 output that I want (it outputs to column3,column4), but it will work for my purpose.
Now I need to incorporate a loop so that the code runs on each successive cell in the column (downwards, step 1) skipping all bolded cells, until it hits an empty cell.
Modified answer to modified request.
This will start on row 1 and continue until a blank cell is found in column A. If you would like to start on a different row, perhaps row 2 if you have headers, change the
i = 1
line to
i = 2
I added a check on the upper bound of our variant before doing the output writes, in case the macro is run again on already formatted cells. (Does nothing instead of erroring out)
Sub EasySplit()
Dim initialText As String
Dim i As Double
Dim name As Variant
i = 1
Do While Trim(Cells(i, 1)) <> ""
If Not Cells(i, 1).Font.Bold Then
initialText = Cells(i, 1).text
name = Split(initialText, "-", 2)
If Not UBound(name) < 1 Then
Cells(i, 1) = Trim(name(0))
Cells(i, 4) = Trim(name(1))
End If
End If
i = i + 1
Loop
End Sub
just add a variable to keep track of the active row and then use that in place of the constant 1.
e.g.
Dim iRow as Integer = ActiveCell.Row
For a = 0 To 1
Cells(iRow , a + 3).Value = Trim(name(a))
Next a
Alternate method utilizing TextToColumns. This code also avoids using a loop, making it more efficient and much faster. Comments have been added to assist with understanding the code.
EDIT: I have expanded the code to make it more versatile by using a temp worksheet. You can then output the two columns to wherever you'd like. As stated in your original question, the output is now to columns 1 and 4.
Sub tgr()
Const DataCol As String = "A" 'Change to the correct column letter
Const HeaderRow As Long = 1 'Change to be the correct header row
Dim rngOriginal As Range 'Use this variable to capture your original data
'Capture the original data, starting in Data column and the header row + 1
Set rngOriginal = Range(DataCol & HeaderRow + 1, Cells(Rows.Count, DataCol).End(xlUp))
If rngOriginal.Row < HeaderRow + 1 Then Exit Sub 'No data
'We will be using a temp worksheet, and to avoid a prompt when we delete the temp worksheet we turn off alerts
'We also turn off screenupdating to prevent "screen flickering"
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Move the original data to a temp worksheet to perform the split
'To avoid having leading/trailing spaces, replace all instances of " - " with simply "-"
'Lastly, move the split data to desired locations and remove the temp worksheet
With Sheets.Add.Range("A1").Resize(rngOriginal.Rows.Count)
.Value = rngOriginal.Value
.Replace " - ", "-"
.TextToColumns .Cells, xlDelimited, Other:=True, OtherChar:="-"
rngOriginal.Value = .Value
rngOriginal.Offset(, 3).Value = .Offset(, 1).Value
.Worksheet.Delete
End With
'Now that all operations have completed, turn alerts and screenupdating back on
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
You can do this in a single shot without looping using the VBA equivalent of entering this formula, then taking values only
as a formula
=IF(NOT(ISERROR(FIND("-",A1))),RIGHT(A1,LEN(A1)-FIND("-",A1)-1 ),A1)
code
Sub Quicker()
Dim rng1 As Range
Set rng1 = Range([a1], Cells(Rows.Count, "A").End(xlUp))
With rng1.Offset(0, 3)
.FormulaR1C1 = "=IF(NOT(ISERROR(FIND(""-"",RC[-3]))),RIGHT(RC[-3],LEN(RC[-3])-FIND(""-"",RC[-3])-1 ),RC[-3])"
.Value = .Value
End With
End Sub
I'm relatively new to VBA and I'm trying to write a macro that will compare two columns of data (first and last names). While traversing the column, any time first name = last name (ie. they're both blank or say UNKNOWN) I want the cell in the 9th column to be cleared and the cell in the 10th column to get the value UNKNOWN.
As of now, the code correctly recognizes any time when the first and last name are identical. My problem is that any time first name is a sub-string of any last name (ie. cell I2=David J2=Jones , I3=Joseph J3=Davidson) David gets compared with Davidson and is subsequently erased.
I've spent a while looking for similar problems and I haven't been able to adapt anything to my problem thus far. Thanks in advance for any help.
Sub compare_cols()
Dim Report As Worksheet
Dim i As Integer, j As Integer
Dim lastRow As Integer
Set Report = Excel.ActiveSheet
lastRow = Report.UsedRange.Rows.count
Application.ScreenUpdating = False
For i = 1 To lastRow ' This will find all identical pairs of cells in I,J (blank, blank) or (unknown, unknown). I stays blank, J gets UNKNOWN
For j = 1 To lastRow ' I think its currently erasing any matches (ex. if someones first name is James, it will get erased if there is a last name jameson)
If InStr(1, Report.Cells(j, 10).Value, Report.Cells(i, 9).Value, vbTextCompare) > 0 Then
Report.Cells(i, 9).Value = ""
Report.Cells(i, 10).Value = "UNKNOWN"
Exit For
Else
End If
Next j
Next i
Application.ScreenUpdating = True
End Sub
Unlike some other languages, you can compare strings in vba just using the "=" sign and that will find exact matches, which is what it appears you are looking for. Try
if Report.Cells(j, 10) = Report.Cells(i, 9) etc.