Am new to VBA Programming Kindly help me in getting the solution.
My code has to accept user defined excel files and take those values of the cells as log which are colored.I am getting error as "Subscript Out of range"
Public color_Change, color_Recall
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim rcell As Range
Dim CellData As String
Dim fso As FileSystemObject
Set fso = New FileSystemObject
Dim stream As TextStream
Set stream = fso.OpenTextFile("D:\Support.log", ForWriting, True)
CellData = ""
Dim vaFiles As Variant
vaFiles = Application.GetOpenFilename()
ActiveSheet.Range("B10") = vaFiles
Set wb = Workbooks.Open(vaFiles)
For Each vaFiles In ActiveWorkbook.Worksheets
Worksheets(vaFiles.Name).Activate
stream.WriteLine "The name of the Tab Sheet is :" & vaFiles.Name
color_Change = getRGB2("A1")
'color_Recall = getRGB2("A2")
For Each rcell In vaFiles.UsedRange.Cells
arrcolor = color_Change
rcell.Interior.Color = getRGB1("A3")
For Each color_Recall In ActiveSheet.UsedRange
If rcell.Interior.Color = arrcolor Then
CellData = Trim(rcell.Value)
stream.WriteLine "The Value at location (" & rcell.Row & "," & rcell.Column & ") " & CellData & " " & rcell.Address
End If
'End If
Next
Next
stream.WriteLine vbCrLf
'Next
'Next
stream.Close
MsgBox ("Job Done")
End Sub
Function getRGB2(ccell) As String
Dim wkb As Workbook
ThisWorkbook.Sheets(Sheet).Activate
'wkb.Activate
Dim i As Integer, rng As Range
Dim r As Byte, g As Byte, B As Byte
Set rng = Range(ccell)
With rng.Interior
r = .Color Mod 256
g = .Color \ 256 Mod 256
B = .Color \ (CLng(256) * 256)
End With
getRGB2 = r & "," & g & "," & B
End Function
Function getRGB1(ccell) As String
Dim wkb As Workbook
ThisWorkbook.Sheets(Sheet).Activate
'wkb.Activate
Dim i As Integer, rng As Range
Dim r As Byte, g As Byte, B As Byte
Set rng = Range(ccell)
With rng.Interior
r = .Color Mod 256
g = .Color \ 256 Mod 256
B = .Color \ (CLng(256) * 256)
End With
getRGB1 = r & "," & g & "," & B
End Function
I can't replicate your error but:
Activate
the sheets, you cant loop through the sheets if you qualify the getRGB1
and getRGB2
functions color_Recall
) that doesn't seem to serve any purpose suggest
For Each vafiles In ActiveWorkbook.Worksheets
stream.WriteLine "The name of the Tab Sheet is :" & vafiles.Name
color_Change = getRGB2(vafiles.Range("A1"))
For Each rcell In vafiles.UsedRange.Cells
arrcolor = color_Change
rcell.Interior.Color = getRGB1(vafiles.Range("A3"))
If rcell.Interior.Color = arrcolor Then
CellData = Trim(rcell.Value)
stream.WriteLine "The Value at location (" & rcell.Row & "," & rcell.Column & ") " & CellData & " " & rcell.Address
End If
Next
Next
The fundamental differences between Subs and Functions are
A Function will usually return something When you call
ThisWorkbook.Sheets(Sheet).Activate
You are trying to change the Workbook object which isn't allowed.
I'm also not sure that ThisWorkbook.Sheets(Sheet) is a valid object unless you've defined Sheet as a global variable.
A Google search for
get rgb color excel
turned up this as the top result
Function getRGB2(rcell) As String
Dim C As Long
Dim R As Long
Dim G As Long
Dim B As Long
C = rcell.Interior.Color
R = C Mod 256
G = C \ 256 Mod 256
B = C \ 65536 Mod 256
getRGB2 = R & "," & G & "," & B
End Function
From http://excel.tips.net/T010179_Determining_the_RGB_Value_of_a_Color.html
Function getRGB2(ccell) As String
Dim wkb As Workbook
ThisWorkbook.Sheets(Sheet).Activate
Instead try this:
Function getRGB2(ccell) As String
Dim wkb As Workbook ' or rename this to Dim ThisWorkbook As Workbook
Set wkb = ActiveWorkbook ' or rename this to Set ThisWorkbook = ActiveWorkbook
wkb.Sheets("Name of the sheet you want").Activate ' or rename this to ThisWorkbook.Sheets("Name of the sheet you want").Activate
I think what your problem is, is that you haven't decleard what wkb/ThisWorkbook will be, you have told it the varible it will be in the Dim but you have then done nothing with it, you need to tell the code which work book you want it to use, after that you can use it in your code.
Hope this helps
If you don't understand what I mean comment and i'll explain it in greater detail if I can.
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.