Transform to VBA code

[wangfat]

Hi
I have the following formula in excel spreadsheet but would like to learn how to write in vba, please advise:

1.
=IF(EXACT(C2,UPPER(C2)),MID(C2,SEARCH("(",C2)+1,SEARCH(")",C2)-SEARCH("(",C2)-1)+0,"")

2.
=IF(EXACT(C2,UPPER(C2)),LEFT(C2,SEARCH("(",C2)-2),"")

C2 can be any cells on column C, ie cells(i,3)

Thanks

 

[Marcelo Branco]

In VBA you can use the functions:
UCase
https://www.techonthenet.com/excel/formulas/ucase.php
InStr
https://www.techonthenet.com/excel/formulas/instr.php
Mid
https://www.techonthenet.com/excel/formulas/mid.php

M.

 

[wangfat]

Hi
Thanks for the info.
I’ve created VBA and extract some data at some point. However, it stops at the statement (qusector = Left(Cells(i, 3), openbracketpos - 2)) when running to the cell C9 (534R4). I think there are blank cells below and can’t proceed. Please advise how to fix.

The purpose is to extract each category and split into text and percentage, eg MUG, 38.5; PLATE, 12.2...
Here is the original data
MUG (38.5%)
33,700 jaf
22,200 534R4


PLATE (12.2%)
31,900 wasd
88,000 fef
72,400 ve
5,800 vw
131,100 v


CUP (10.6%)
64,870 rwer
85,300 vasd
88,760 jytj
26,900 mjk
54,800 mhg
66,600 dhfg

and here is the code:

Sub copypastecolumndata()

Dim i As Integer
Dim j As Integer
Dim qusector As String
Dim quper As String
Dim lastrow As Long
Dim openbracketpos As Integer
Dim closebracketpos As Integer
Dim lrow As Integer

Sheet3.Select
Sheet3.Cells.ClearContents
Range("a1") = "Sectors"
Range("b1") = "Percent"

Sheet1.Select
lastrow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row

For i = 7 To lastrow
openbracketpos = InStr(Cells(i, 3), "(")
closebracketpos = InStr(Cells(i, 3), ")")



If Cells(i, 3) = UCase(Cells(i, 3)) Then
qusector = Left(Cells(i, 3), openbracketpos - 2)



lrow = Sheet3.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Sheet3.Cells(lrow, 1) = qusector

If Cells(i, 3) = UCase(Cells(i, 3)) Then
quper = Mid(Cells(i, 3), (openbracketpos + 1), (closebracketpos - openbracketpos - 2))

Sheet3.Cells(lrow, 2) = quper


End If
End If
Next i

End Sub

 

[Marcelo Branco]

The code must check if the parenthesis are present in the string.
So, after these code lines

openbracketpos = InStr(Cells(i, 3), "(")
closebracketpos = InStr(Cells(i, 3), ")")

Insert an IF like this

If openbracketpos > 0 And closebracketpos > 0 Then
    'your code here
End If

M.

 

[wangfat]

Hi
Thank you. It works.

Regards

 

[Marcelo Branco]

Hi
Thank you. It works.

Regards

You are welcome. Thanks for the feedback.

M.

 

[wangfat]

Hi
I want to go one more step to extract these data to other workbook instead of the existing file and here is the code. It only extracts the first data of each file but not all using F5. However, when I use F8 (step into) very slowly, it can extract more in each file, but it does not always work. Please advise how to correct.

QUOTE

Sub copydata()

Dim i As Integer
Dim qusector As String
Dim quper As String
Dim fundno As String
Dim openbracketpos As Integer
Dim closebracketpos As Integer
Dim FolderPath As String
Dim Filepath As String
Dim Filename As String
Dim lrow As Long
Dim lastrow As Long
Dim lastcolumn As Long
Dim wb As Workbook

'Clear content
Sheets("Summary").Select
Columns("A:C").Select
Selection.ClearContents
Range("A1").Value = "Fund"
Range("B1").Value = "Sector/Country"
Range("C1").Value = "Percentage"

'get file
FolderPath = Range("J1")
Filepath = FolderPath & Range("J3")
Filename = Dir(Filepath)

'get data from each file
Do While Filename <> ""
Set wb = Workbooks.Open(FolderPath & Filename)
wb.Worksheets("portfolio").Activate
lastrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

fundno = Sheets("variables").Cells(1, 95)

For i = 7 To lastrow
openbracketpos = InStr(Cells(i, 3), "(")
closebracketpos = InStr(Cells(i, 3), ")")

If closebracketpos * openbracketpos > 0 Then
If Cells(i, 3) = UCase(Cells(i, 3)) And Cells(i, 3).Font.Bold = True Then
qusector = Left(Cells(i, 3), openbracketpos - 2)
quper = Mid(Cells(i, 3), (openbracketpos + 1), (closebracketpos - openbracketpos - 2))

'transfer to another workbook
Workbooks("MasterNEW.xlsm").Worksheets("Summary").Activate
lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

Cells(lrow, 1) = fundno
Cells(lrow, 2) = Trim(qusector)
Cells(lrow, 3) = quper

End If
End If
Next i

wb.Close savechanges:=False

Filename = Dir

Loop


lrow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Cells(lrow, 1).Select

Sheets("Summary").Range("A:C").Columns.AutoFit

End Sub
UNQUOTE

Regards

 

[Marcelo Branco]

I don't know why your code is not working. It's hard to test a code that deals with multiple workbooks.

By the way, use the code tags when posting a code, that is.
[ CODE ]
your code here
[ /CODE]

without the spaces

M.