Posts by smuzoen

Re: Excel VBA Array Problem

As StephenR said you create a 2-D array - to make it easier you can transpose it into a 1-D array

allSites = Application.Transpose(Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row))
MsgBox allSites(siteLoop)

Re: output to empty cell range..

I am assuming you have another function called IsAlphaNumeric? This determines if the string is composed of only alphabet (a-z) and/or numbers? I assume you are trying to write to Sheet2 in column L? If no to any of these then you need to be more specific or supply a sample workbook - you could try something like

Function CountWords(txt)
Dim arr() As String
Dim i As Long, lastRow As Long
arr = Split(txt, " ")
'Find next free row in Column L
lastRow = Sheet2.Cells(Rows.Count, "L").End(xlUp).Row + 1


'iterate through the array of strings
For i = LBound(arr) To UBound(arr)
    If Len(arr(i)) = 8 Or Len(arr(i)) = 9 Then
        'Call another function to determine if string is alphanumeric
        If IsAlphaNumeric(arr(i)) Then
            'Write data to Sheet 2 Column L
            Sheet2.Range("L" & lastRow) = arr(i)
            lastRow = lastRow + 1
        End If
    End If
   
Next
End Function

Re: Converting Data into number Data

Where or how do you get the value in the first place - is it an import from a file? Unusual character to have in the cell. As cytop said you have ASCII 160 - if you want the specific format you could
=TEXT(SUBSTITUTE(SUBSTITUTE(B3,CHAR(160),"")," ",""),"#,##00")

However this is a text - cytop has a better solution in that you should format the cell.

Re: Color Macro $30

Just as an option to make the code nice and succinct and promote reuse of code

'================================================================================
    'Colour My Cells
    'Copyright (C) 2014  Smallman




    'This program is free software: you can redistribute it and/or modify
    'it under the terms of the GNU General Public License as published by
    'the Free Software Foundation GPLv3




    'This program is distributed in the hope that it will be useful,
    'but WITHOUT ANY WARRANTY; without even the implied warranty of
    'MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    'GNU General Public License for more details.




    'For a copy of the GNU General Public License
    'see http://www.gnu.org/licenses/
'================================================================================
Option Explicit


'Constants for the various colours
Const BLUE = 16711680
Const RED = 255
Const GREEN = 65280
Const NONE = -4142




Sub BlueThrough()
'Turns the slection Blue if there is more than 1 cell selected
Call ColourMe(BLUE)
End Sub




Sub RedFaster()
'Turns the slection Blue if there is more than 1 cell selected
Call ColourMe(RED)
End Sub




Sub Greeny()
'Turns the slection Blue if there is more than 1 cell selected
Call ColourMe(GREEN)
End Sub




Sub GotNothing()
'Turns the slection Blue if there is more than 1 cell selected
Call ColourMe(NONE)
End Sub
 
Sub ColourMe(chosenColour As Long)
Dim var As Variant
Dim i As Long
     'Turns the slection chosed colour if there is more than 1 cell selected
    var = Array(xlEdgeLeft, xlEdgeTop, xlEdgeBottom, xlEdgeRight, xlInsideVertical, xlInsideHorizontal)
     'Boarder process and trap for only 1 cell selected.
    If Selection Is Nothing Then
        MsgBox "Select something"
    Else
        Selection.FormatConditions.Delete
        Selection.Interior.Color = chosenColour
        For i = LBound(var) To UBound(var)
            With Selection.Borders(var(i))
                .ThemeColor = 1
                .TintAndShade = -0.14996795556505
                .Weight = xlThin
            End With
        Next i
    End If
End Sub

Re: Color Macro $30

Could you succinctly and clearly outline what further work has to be done to finalise this development? Does the code posted by Smallman satisfy yor requirements. ? If not what is the problem with the current code? To save a lot of time reading 30+ posts if you could briefly and clearly state what remains to be done, what modifications to the existing code are required to satisfy your requirements then perhaps this development may be finalised.

Re: how to crate Login form in Excel

Just a few notes - Excel security is extremely poor - if you are storing very sensitive information then I would not recommend Excel as a potential solution for you. However...for the "average user" it would probably suffice. If all the information is stored within Excel, even if the sheet is hidden (or very hidden) and it is of a sensitive nature, then password protecting the workbook would be required. However the problem is Excel and security - to break the password is not difficult but as previously stated...for keeping out the average user it may suffice. It depends on how personal the information is that you intend to record within the document.
As with any problem - consider if the tools are adequate for your requirements.

Re: Counting with multiple criteria without user pivot tables

Have to agree with Smallman - another option is Sumproduct - why make it difficult unless you particularly want to learn VBA or make this an exercise in VBA coding.
If I can offer you one piece of advice - if the Result table is going to be used elsewhere as a source of data ditch the merged cells - merged cells are evil and will cause you nothing but grief. Merged cells should be banned (IMO)

Usage Sumproduct
=SUMPRODUCT(--($B$4:$B$14="A"),--($C$4:$C$14="buy"),--($D$4:$D$14=$B$18))
See attached workbook

Re: Userform edit file multirows

Exactly as Roy said - you are getting errors because RowFound1,RowFound2 etc have no value so

.Cells(RowFound1, "M") = ritem1.Text
'is the same as
.Cells(null, "M") = ritem1.Text

These variables "appear to be declared" but never assigned a value - if excel does not know what row "RowFound1" refers to how can the value from the textbox be entered into the worksheet. In actual fact these variables are NOT declared as far as the code is concerned. Is this just cut and pasted from some other code? Did they assign values somewhere to these variables (and these variables should be declared within the Button Click event not outside as Roy has already pointed out). You probably need to get back to some basics and understand what is going on with the code.

Re: Macro won't stop creating zipped files

Without seeing the workbook you have a loop

For I = 2 To RowCount + 1

Depending on the length of Column C you have the code for creating the zip file in a loop - that is why you ar getting multiple zip files created - the code for creating the zip files is within a loop - any reason for that? Why put directory into array FName then test if it is an array? Have you cut and pasted this code from somewhere? You loop variable is I then you reset the value of loop variable and then change its value which is really poor programming practice. To tell you the truth it is not the greatest bit of code.

Re: Subtracting from time

If you type in A1 - "1 am"
Type in B1 - "9 am"
Type in C1 "=B1 - A1"
Format C1 as hh:mm - Result will be 8:00 (representing 8 hours)
Dont use the "" - just what is inside the " "

Google is your friend - http://office.microsoft.com/en-us/excel-help/add-or-subtract-time-HA102809662.aspx

Re: Excel VBA With Range --- End With string manupulation help

Your example is not a "classic" loop - you would need to

Sub RangeLoop()
Dim myRng As Range, mr As Range




Set myRng = Range("C1:F102")
For Each mr In myRng
    '.......manipulate cell as per your rules
Next
End Sub

Re: move several columns and sort according to the one particular column

Try - See attached workbook - if I understand your logic the following should do what you require

Option Explicit
Enum position
Left
Right
End Enum




Sub CheckMatches()


Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim arr1 As Variant, arr2 As Variant
Dim k As Long, pos As Long


Set ws1 = Worksheets("Sheet1"): Set ws2 = Worksheets("Sheet2"): Set ws3 = Worksheets("Sheet3")
ws3.Range("A2").Resize(ws3.Cells(Rows.Count, "A").End(xlUp).Row, ws3.Cells(1, Columns.Count).End(xlToLeft).Column).Clear
'get Data into arrays
arr1 = Application.Transpose(ws1.Range("A2:A" & ws1.Cells(Rows.Count, "A").End(xlUp).Row))
arr2 = Application.Transpose(ws2.Range("A2:A" & ws2.Cells(Rows.Count, "A").End(xlUp).Row))


For k = LBound(arr1) To UBound(arr1)
    If Not IsError(Application.Match(arr1(k), arr2, False)) Then
        pos = Application.Match(arr1(k), arr2, False)
        Call CopyAllData(k, pos, ws1, ws2, ws3)
        arr2(pos) = vbNullString
    Else
         Call CopySingleData(k, ws1, ws3, Left)
    End If
Next
pos = ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1
For k = LBound(arr2) To UBound(arr2)
    If arr2(k) <> vbNullString Then
        Call CopySingleData(k, ws2, ws3, Right, pos)
        pos = pos + 1
    End If
Next
End Sub




Sub CopyAllData(index1 As Long, index2 As Long, ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet)


ws1.Range("A" & index1 + 1).Resize(, 11).Copy
ws3.Range("A" & ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
ws2.Range("A" & index2 + 1).Resize(, 11).Copy
ws3.Range("M" & ws3.Cells(Rows.Count, "A").End(xlUp).Row).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End Sub




Sub CopySingleData(index1 As Long, ws As Worksheet, ws3 As Worksheet, side As position, Optional pos As Long)


ws.Range("A" & index1 + 1).Resize(, 11).Copy
If side = Left Then
    ws3.Range("A" & ws3.Cells(Rows.Count, "A").End(xlUp).Row + 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Else
    ws3.Range("M" & pos).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End If
End Sub

Re: move several columns and sort according to the one particular column

And if there is no match the row is moved to its own row on sheet 3? If no match of data on Sheet 1 then copy to left side of Sheet 3 and if no data match on Sheet 2 then move to Right side of Sheet3? Is that correct?

Re: hard queston about vb

You cannot do that - you could open the workbook containing the worksheet via vba code.

Dim wb As Workbook
Dim ws As Worksheet
Set wb = Workbooks.Open("C:\Temp\Book2.xlsx")
Set ws = wb.Worksheets("Mainreport")
wb.Activate
    If Me.TextBox51.Text <> "" Then
....

However if the value does not exist on VLookUp you will get an error so you will need to use something like

On Error Resume Next
......
if err.Number<>0 then
....

Re: Excel VBA With Range --- End With string manupulation help

Quote

If I put MsgBox .value inside the block it comes up with type miss match error.

How are you returning a value from a MsgBox?

x = MsgBox("Continue", vbYesNo)

Quote

get rid of any "," at the end of all strings

If Mid(x, Len(x), 1) = "," Then
    x = Replace(x, x, Mid(x, 1, Len(x) - 1))
End If
MsgBox x

Quote

reduce the font size by 1pt (now its if the lenght of the string is over 43

Test for length with (you would probably have to loop through range)

If Len(Range(....)) > 43 then
Range(...).Font.Size = 7

Quote

split up the text to different cells if the string lenght is over 43 and there is a coma in the string and the adjacent cell to the right is empty

I am using static ranges however you will get the point - I assume you want it split at comma (and assume only one comma)

Dim varArr As Variant
If Len(Range("G6")) > 43 And InStr(Range("G6"), ",") > 0 And Range("G6").Offset(, 1) = vbNullString Then
    varArr = Split(Range("G6"), ",")
    Range("G6") = varArr(0)
    Range("H6") = varArr(1)
End If

Re: Search and Replace text

Just checking if you want to proceed with work or would you like to have the thread closed. No problem if you don't want to proceed.

Re: vba Binary code to read text file & search particular word & amount associated wi

You don't have a binary file however you can open a text file for Binary Access as snb has done (or Sequential/Random access). As cytop said you either have a binary file or a text file - they are NOT the same thing. There are certain advantages to binary files which you can find with Google. Why you want this opened for binary access I do not know. To do what you want you can open the text file and test each line to see if your name is present then use a regular expression to write out the results. See attached workbook. I have only used a very basic regular expression pattern however again Google is your friend is you want to be more specific wrt currency format.

Option Explicit




Sub ReadTextFile()




    Dim fName As String
    Dim iFileNum As Integer
    Dim buffer As String
    Const USERNAME = "Rahaman"
    
    'Change to location of your text file
    fName = "C:\temp\test.txt"
    If Len(Dir$(fName)) = 0 Then
        MsgBox "File does not exist", vbCritical
        Exit Sub
    End If
    iFileNum = FreeFile()
    Open fName For Input As iFileNum




    Do While Not EOF(iFileNum)
        Line Input #iFileNum, buffer
        If InStr(buffer, USERNAME) > 0 Then
            Call WriteToSheet(buffer, USERNAME)
        End If
    Loop
    Close iFileNum
End Sub




Sub WriteToSheet(data As String, nameStr As String)
 Dim regex As Object, regMatch As Object
     
    Set regex = CreateObject("vbscript.regexp")
    With regex
        .MultiLine = True
        .Global = True
        .IgnoreCase = True
        .Pattern = "\$[ 0-9,.]*"
    End With
     
    Set regMatch = regex.Execute(data)
    If regex.test(data) Then
        Range("A" & Cells(Rows.Count, "A").End(xlUp).Row + 1) = nameStr
        Range("B" & Cells(Rows.Count, "A").End(xlUp).Row) = regMatch(0)
    End If
End Sub

Re: I want to create labelling by using macro kindly help

I have changed this so that you enter the start label and then enter the final NUMBER of the label - e.g. Starting Label A0006, Final Number 600 - see attached workbook

Option Explicit




Sub AddLabels()




Const LABELROWCOUNT = 9
Const LABELCOLUMNCOUNT = 6
Dim textToAdd As String, firstLetter As String, finalNo As String
Dim startNo As Long, endNo As Long
Dim k As Integer, j As Integer, i As Integer, pageNo As Integer, startRow As Integer




startRow = 2
textToAdd = InputBox(Prompt:="Enter the Starting label e.g. A0001", _
          Title:="ENTER THE STARTING LABEL")
finalNo = InputBox(Prompt:="Enter the Ending label NUMBER e.g. 65", _
          Title:="ENTER THE LAST LABEL NUMBER")
firstLetter = Left$(textToAdd, 1)
startNo = CLng(Mid(textToAdd, 2, Len(textToAdd) - 1))
endNo = CLng(finalNo)
'calculate pages required
pageNo = Application.WorksheetFunction.RoundDown(endNo / (LABELROWCOUNT * LABELCOLUMNCOUNT), 0) + 1
For i = 1 To pageNo
    For k = 1 To LABELROWCOUNT
        For j = 1 To LABELCOLUMNCOUNT
            Cells(startRow, j * 2) = Left(UCase(firstLetter) & String(Len(textToAdd) - Len(CStr(startNo)), "0"), _
                Len(textToAdd) - Len(CStr(startNo))) & CStr(startNo)
            If startNo = finalNo Then GoTo finalSub
            startNo = startNo + 1
        Next
        startRow = startRow + 2
    Next
    startRow = startRow + 1
Next
finalSub:
    MsgBox "Labels Completed", vbInformation
End Sub

Re: I want to create labelling by using macro kindly help

Will there always be a letter at beginning of label? I can change the code so you enter start number and end number. Just let me know if format of label always has a letter at beginning.

Re: Search and Replace text

You can upload a sample workbook when you create a post. When you post to thread Select "Go Advanced" and select your workbook and attach to the post. I will PM my email address and you can send the workbook by email if you prefer. The 10% must be paid to Ozgrid via PayPal before any solution can be developed. Once you have paid the 10% please confirm by posting into thread that it has been paid. The time frame you quoted is fine. It is late here so I will check thread in morning. I will PM my email to you now.