PDA

View Full Version : [SOLVED] VBA from text to number



Sophia
10-15-2019, 08:18 AM
Hi Guys,

I need to crete macros to exctract (1) and (702) numbers without brakets from this text, converted it to 702_1 format and change sheet name to 702_1 automatically.

text is on the same sheet which need to be changed. (several sheets like that not one)

current sheet name is Sheet1, Sheet2,...

No other numbers in text

Is it possible?

Paul_Hossler
10-15-2019, 08:32 AM
Q: You need to create a macro to extract the '1' and the '708' part of '(1)' and '(708)' without the parentheses, and rename the worksheet to '702_1' ?

Where did the (1), the (708), and the '702_1' come from?

A lot more information and detail would be helpful

Sophia
10-15-2019, 08:42 AM
Soory my bad I adjusted the message just typing error

Paul_Hossler
10-15-2019, 08:54 AM
And the additional details?

Where is the text? (e.g. A1)

Always in the same place?

What does the rest of (the cell???) text look like? (e.g. "Sometext (1) and some more (702) and still some more")

Sophia
10-15-2019, 09:00 AM
Text is in A6 always in same place in all sheets
this report is from sytem

these are 3 examples of text

Fund: UNRESTRICTED FUND (1), Department: MATCHING GIFT (722)
Fund: UNRESTRICTED FUND (1), Department: HALL OF FAME DINNER (720)
Fund: TEMPORARILY RESTRICTED FUND (2), Department: PIRO GENERAL SCHOLARSHIP (905)

Sophia
10-15-2019, 09:05 AM
oh God

Fund: PERMANENTLY RESTRICTED FUND (3), Department: CLASS OF 1988 MEMORIAL FACULTY ENRICHMENT ENDOW (979)

I have example like this where 1988 is the just name of the class which I dont need :(

I need department code_fund code
department code is always at the end

Sophia
10-15-2019, 11:30 AM
seems tsk is really difficult :think:

SamT
10-15-2019, 11:51 AM
Option Explicit

Sub Rename_Dept_Fund_Sheets()
'This will skip any Sheet with an A6 String that does not have exactly 2 complete sets of parentheses
'Example: Fund: UNRESTRICTED FUND 1), Department: HALL OF FAME DINNER (720)
'Example: Fund: UNRESTRICTED FUND 1, Department: HALL OF FAME DINNER (720)
'Example: Fund: UNRESTRICTED FUND (1), Department (#3): HALL OF FAME DINNER (720)

Dim FundNum As String
Dim DeptNum As String
Dim X As Variant
Dim Sht As Worksheet

For Each Sht In ActiveWorkbook.Sheets
If Not InStr(Sht.Range("A6"), ")") = 2 Then GoTo NextSht 'Note the last close Paren is part of InStr()
If Not InStr(Sht.Range("A6"), "(") = 2 Then GoTo NextSht
On Error GoTo NextSht

X = Split(Sht.Range("A6"), "(") 'pay attention to the structure of Split. The last Close Paren is part of Split()
FundNum = Split(X(1), ")")(0) 'X(1) is the second element of X, (0) is the first element of Split
DeptNum = Split(X(2), ")")(0) 'X(2) is the third element of X, (0) is the first element of Split
Sht.Name = DeptNum & "_" & FundNum
NextSht:
Next Sht

End Sub


I recommend you place this code in a module in the "Personal" Workbook and run it from the Macro menu in the workbook you want to rename the sheets in.

Paul_Hossler
10-15-2019, 12:15 PM
Not difficult at all



Option Explicit


Sub Do_Dept_Fund()
Dim ws As Worksheet
Dim sNewName As String

For Each ws In Worksheets
sNewName = Dept_Fund(ws.Range("A6").Value)

If Len(sNewName) > 0 Then ws.Name = sNewName
Next


End Sub




Private Function Dept_Fund(s As String) As String
Dim p1 As Long, p2 As Long, p3 As Long, p4 As Long

p1 = 0
p2 = 0
p3 = 0
p4 = 0

On Error GoTo NoCanDo
p1 = InStr(1, s, "(", vbBinaryCompare)
p2 = InStr(1, s, ")", vbBinaryCompare)
p3 = InStr(p1 + 1, s, "(", vbBinaryCompare)
p4 = InStr(p2 + 1, s, ")", vbBinaryCompare)

Dept_Fund = Mid(s, p3 + 1, p4 - p3 - 1) & "_" & Mid(s, p1 + 1, p2 - p1 - 1)
On Error GoTo 0


Exit Function

NoCanDo:
Dept_Fund = vbNullString


End Function

Sophia
10-15-2019, 12:55 PM
Thanks Paul I am able to run it :clap:

Paul_Hossler
10-15-2019, 01:00 PM
The modified version I just updated -- FundDept_1.xlsm -- is a little better

I started thinking worksheet functions, and didn't reset my all of mental gears to stay with a simpler VBA approach

You can mark your post SOLVED -- #3 in my sig

Paul_Hossler
10-15-2019, 01:10 PM
@SamT -

I'm always looking to learn, but are you sure this is correct?





If Not InStr(Sht.Range("A6"), ")") = 2 Then GoTo NextSht 'Note the last close Paren is part of InStr()
If Not InStr(Sht.Range("A6"), "(") = 2 Then GoTo NextSht


I tried your macro in the sample WB I used, but nothing happens

For

A6 = "Fund: UNRESTRICTED FUND (1), Department: MATCHING GIFT (722)"

Instr(A6, "(" = 25

Were you thinking of counting the )'s ?

SamT
10-15-2019, 01:23 PM
Were you thinking of counting the )'s ?:banghead::banghead::banghead::banghead::banghead::banghead::banghead::ban ghead:

And of course, I wrote the Edge Case error checking after testing the basic functionality.:crying:

This works
Dim FundNum As String
Dim DeptNum As String
Dim X As Variant
Dim Sht As Worksheet

For Each Sht In ActiveWorkbook.Sheets
On Error GoTo NextSht
X = Split(Sht.Range("A6"), "(") 'pay attention to the structure of Split. The last Close Paren is part of Split()
FundNum = Split(X(1), ")")(0) 'X(1) is the second element of X, (0) is the first element of Split
DeptNum = Split(X(2), ")")(0) 'X(2) is the third element of X, (0) is the first element of Split
Sht.Name = DeptNum & "_" & FundNum
NextSht:
Next Sht

End Sub

SamT
10-15-2019, 01:28 PM
Were you thinking of counting the )'s ?:banghead::banghead::banghead::banghead::banghead::banghead::banghead::ban ghead:

And of course, I wrote the Edge Case error checking after testing the basic functionality.:crying:
thank you for that little reminder. :thumb

This works
Dim FundNum As String
Dim DeptNum As String
Dim X As Variant
Dim Sht As Worksheet

For Each Sht In ActiveWorkbook.Sheets
On Error GoTo NextSht
X = Split(Sht.Range("A6"), "(") 'pay attention to the structure of Split. The last Close Paren is part of Split()
FundNum = Split(X(1), ")")(0) 'X(1) is the second element of X, (0) is the first element of Split
DeptNum = Split(X(2), ")")(0) 'X(2) is the third element of X, (0) is the first element of Split
Sht.Name = DeptNum & "_" & FundNum
NextSht:
Next Sht

End Sub
I shudda left it at that:wot

Sophia
10-15-2019, 01:54 PM
Yes it is wow thank you guys.
I am really appreciate :thumb