Split a workbook into multiple workbooks based on sheet name.

1). Copy below code in fresh workbook module
2). Change the workbook path in code, i have used Book1.xlsx which is there on desktop. hence it's Environ("USERPROFILE") & "\Desktop\Book1.xlsx"
3). Run the code, it will prompt you for no. of copies you want
4). it will automatically save the newly created workbooks in the same location as your original workbook is.
------------------------------------------------ ----------------------------
Sub splitWorkbook()
Dim wkb As Workbook, wks As Worksheet
Dim wksCount As Integer, noOfWkb As Integer, noOfWksInWkb As Integer, wkbCounter As Integer
Dim sheetArr(), tempArr(), wksNameStr As String

'assuming that my workbook is on desktop with Book1.xls as name
'change this path as per your workbook location
Set wkb = Workbooks.Open(Environ("USERPROFILE") & "\Desktop\Book1.xlsx")
wkb.Application.Visible = False

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim i As Integer, j As Integer
wksCount = wkb.Worksheets.Count
noOfWkb = InputBox("How many workbook do you want?", "NKC", 1)
If noOfWkb > wksCount Then Exit Sub

noOfWksInWkb = Int(wksCount / noOfWkb)
ReDim sheetArr(wksCount - 1)
i = 0

For Each wks In wkb.Worksheets
sheetArr(i) = wks.Name
i = i + 1
Next


ReDim tempArr(noOfWksInWkb)

For i = 0 To UBound(sheetArr)
If wksCount - i > noOfWksInWkb Then
For j = 0 To noOfWksInWkb
tempArr(j) = sheetArr(j + i)
Next
wkbCounter = wkbCounter + 1
Else
ReDim tempArr(wksCount - ((noOfWksInWkb + 1) * wkbCounter + 1))

For j = 0 To UBound(tempArr)

tempArr(j) = sheetArr(j + i)
Next

End If

wkb.Sheets(tempArr).Copy
ActiveWorkbook.SaveAs tempArr(LBound(tempArr)) & " to " & tempArr(UBound(tempArr))
ActiveWorkbook.Close False
i = i + noOfWksInWkb
Next

wkb.Close False
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

Create a scrolling table in excel. no VBA !

I'm going to show you how to create a scrolling table in excel.

You just need 2 scroll bars that's it. Of course you sample/real data. :)

Follow the steps mentioned below.

1). Create 3 sheet(or rename the existing one). "Report", "Staging and Lookup" and "Source_Data."

2). Place 2 scroll bar (form control) in Report sheet as shown in image below.

3).  Right click on horizontal scroll bar control and select "Format Control..".
4).  Now you will have to give a cell link to this control.Give it to cell B2 in "Staging and Lookup" sheet. Shown in image below.

5).  Follow the above steps 3rd and 4th step for vertical scorll bar.  Give cell link to cell B3 in "Staging and Lookup" sheet.

6). Now its time to create a staging table(see image below).  I have created a table to display 5 columns(0-4) and 8(0-7) rows of data. You can increase or decrease the number of rows and columns depending on your table requirement.

  7). Its time to put some formula now. Put your row no. formula as shown below, copy the same formula till end..

8). Put formula as shown below for column no. and copy the same formula till end.

9).Put some data in "Source_Data" sheet and name the entire data range as "Data_Table".

10). Come back to "Staging and Lookup" sheet. Use offset function to populate data for display. If you want row data to be static on horizontal scrollbar click, use stating index(column G) else use dynamic index (column H). Same goes for columns data.

Click for a sample of workbook  

UDF to sum the cells when they are too large for excel to handle

Sometime you get a large string to be entered as formula(returned by a script or code) and that formula can go beyond excel limitation.  In this case excel can not compute this large string of formula.

This is where this UDF will help.  It splits the formula string on basis of consistent delimiter and then uses application.evaluate method to calculate it and sum them up.


Public Function sumCells(expressionStr As String) As Double
   
    Dim expressionArr() As String
    Dim currentExp As String
    Dim currExpValue As Double
    Application.Volatile
        'split and store in array
        expressionArr = Split(expressionStr, "+")
       
        'evaluate every element and sum them up if its numeric
        For i = 0 To UBound(expressionArr)
            currExpValue = Application.Evaluate(expressionArr(i))
            If IsNumeric(currExpValue) Then
                    sumCells = sumCells + currExpValue
            End If
        Next

    If Not IsNumeric(sumCells) Then
        sumCells = "-"
    End If
    Erase expressionArr
End Function

Add ISERROR function in your formula using VBA.

One simple procedure that will help you in putting/
removing ISERROR function in your formula.
Procedure:
-----------------------------------------------------------
Public Function AddOrRemoveIsError(AddOrRemove As String, targetRange
As Range, onErrorPrint As String)
Dim cRng As Range
Dim strOldFormula As String, strNewFormula As String
Dim printValueIsNumber As Boolean
If UCase(AddOrRemove) = "ADD" Or UCase(AddOrRemove) = "REMOVE"
Then
Else
MsgBox "Not a valid type"
Exit Function
End If
On Error Resume Next
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'check if printed string is number
If IsNumeric(onErrorPrint) Then
printValueIsNumber = True
End If
'loop through cells and add remove iserror function
For Each cRng In targetRange
'check if current cell has formula
If cRng.HasFormula Then
'store the old formula
strOldFormula = Right(cRng.Formula, Len(cRng.Formula) - 1)
If UCase(AddOrRemove) = "ADD" Then
If InStr(UCase(cRng.Formula), "ISERROR") = 0 Then
If printValueIsNumber = True Then
strNewFormula = "=IF(ISERROR(" & strOldFormula &
")," & onErrorPrint & _
"," & strOldFormula & ")"
Else
strNewFormula = "=IF(ISERROR(" & strOldFormula &
"),""" & onErrorPrint & _
"""," & strOldFormula & ")"
End If
cRng.Formula = strNewFormula
End If
Else
If InStr(UCase(cRng.Formula), "ISERROR") <> 0 Then
If printValueIsNumber = True Then
strNewFormula = "=" & Mid(strOldFormula, InStr(1,
strOldFormula, "," & _
onErrorPrint & ",") + Len("," & onErrorPrint &
","), Len(strOldFormula) - InStr(1, strOldFormula, "," & _
onErrorPrint & ",") - Len("," & onErrorPrint &
",")) & ""
Else
strNewFormula = "=" & Mid(strOldFormula, InStr(1,
strOldFormula, ",""" & _
onErrorPrint & """,") + Len(",""" & onErrorPrint
&
""","), _
Len(strOldFormula) - InStr(1, strOldFormula,
","""
& onErrorPrint & """,") - _
Len(",""" & onErrorPrint & """,")) & ""
End If
cRng.Formula = strNewFormula
End If
End If
End If
Next
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Function
--------------------------------------------------
How to use :
Copy above procedure and paste in a VBA module
Now, copy the below code and adjust it as per your requirement. In
below code the first call will put ISERROR function in range A1 to D3
and second call will remove it(in case you want to revert).
Sub test()
Call AddOrRemoveIsError("Add", Range("A1:D3"), "-") ' To add isError
Call AddOrRemoveIsError("Remove", Range("A1:D3"), "-") ' To remove
isError
End Sub

Filter function for 2 dimensional array in VBA.

There is filter function in VBA for one dimensional array. What about
2 dimensional array?
Below function helps you in filtering 2D array.


Copy below Function in your VBA module.
--------------------------------------------------------------------------- --------------
Public Function filter2dArray(sourceArr As Variant, matchStr As
String) As Variant
Dim matchArrIndex As Variant, splitArr As Variant
Dim i As Integer, outerindex As Integer, innerIndex As Integer,
tempArrayIndex As Integer, CurrIndex As Integer, stringLength As
Integer, matchType As Integer
Dim increaseIndex As Boolean
Dim actualStr As String
splitArr = Split(matchStr, "*")
On Error GoTo errorHandler
If UBound(splitArr) = 0 Then
matchType = 0 'Exact Match
actualStr = matchStr
ElseIf UBound(splitArr) = 1 And splitArr(1) = "" Then
matchType = 1 'Starts With
actualStr = splitArr(0)
ElseIf UBound(splitArr) = 1 And splitArr(0) = "" Then
matchType = 2 'ends With
actualStr = splitArr(1)
ElseIf UBound(splitArr) = 2 And splitArr(0) = "" And splitArr(2) = ""
Then
matchType = 3 'contains
actualStr = splitArr(1)
Else
MsgBox "Incorrect match provided"
Exit Function
End If
'start index
i = LBound(sourceArr, 1)
'resize array for matched values
ReDim matchArrIndex(LBound(sourceArr, 1) To UBound(sourceArr, 1)) As
Variant
'outer loop
For outerindex = LBound(sourceArr, 1) To UBound(sourceArr, 1)
'inner loop
For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
'if string matches with array elements
If (matchType = 0 And sourceArr(outerindex, innerIndex) =
actualStr) Or _
(matchType = 1 And Left(sourceArr(outerindex, innerIndex),
Len(actualStr)) = actualStr) Or _
(matchType = 2 And Right(sourceArr(outerindex,
innerIndex), Len(actualStr)) = actualStr) Or _
(matchType = 3 And InStr(sourceArr(outerindex,
innerIndex), actualStr) <> 0) Then
increaseIndex = True
matchArrIndex(i) = outerindex
End If
Next
If increaseIndex Then
tempArrayIndex = tempArrayIndex + 1
increaseIndex = False
i = i + 1
End If
Next
'if no matches found, exit the function
If tempArrayIndex = 0 Then
Exit Function
End If
If LBound(sourceArr, 1) = 0 Then
tempArrayIndex = tempArrayIndex - 1
End If
'resize temp array
ReDim tempArray(LBound(sourceArr, 1) To tempArrayIndex,
LBound(sourceArr, 2) To UBound(sourceArr, 2)) As Variant
CurrIndex = LBound(sourceArr, 1)
Dim j As Integer
j = LBound(matchArrIndex)
'store values in temp array
For i = CurrIndex To UBound(tempArray)
For innerIndex = LBound(sourceArr, 2) To UBound(sourceArr, 2)
tempArray(i, innerIndex) = sourceArr(matchArrIndex(j),
innerIndex)
Next
j = j + 1
Next
filter2dArray = tempArray
Exit Function
errorHandler:
MsgBox "Error :" & Err.Description
End Function
-----------------------------------------------------------------
How to use it:

Syntax: filter2dArray(myArray, "*Item1*")
This function require 2 parameters.
1). SourceArray 2). MatchString
MatchString parameter can be passed in following 4 switches:
myStr - Exact Match
myStr* - Starts with
*myStr - Ends with
*myStr* - Contains

Limitations: it will not work on one dimensional array.

Retrieving Webpage data using VBA.

Sample code is stated below.

Workbook Sample: https://www.box.net/shared/x11kv1xl9bpqfdj6llk0

NOTE: This will retrieve data from a webpage only if that is available
in a table.


Sub getTableFromWeb()
Dim queryTableFromWeb As QueryTable
Dim strTableIndex As String
'table number to fetch
strTableIndex = 1
'change the URL as per your requirement
Set queryTableFromWeb = ActiveSheet.QueryTables.Add( _
Connection:="URL;http://www.weatheronline.co.uk/India/
Mumbai.htm", _
Destination:=Range("A1"))
With queryTableFromWeb
.WebSelectionType = xlSpecifiedTables
.WebTables = strTableIndex
.Refresh BackgroundQuery:=False
.SaveData = True
End With
Set queryTableFromWeb = Nothing
End Sub