Free Microsoft Excel 2013
Quick Reference
Free Microsoft 2013 Quick Reference Guide

Free Microsoft Excel 2013 Quick Reference

Count text as value of 0 5 not one Results

Hello,

This is my first post in the forum. I am new to excel VBA and have searched many of the posts and found the responses very helpful. I thought someone might be able to help me with my current project.

I would like for a userform to copy data that is selected/entered into a spreadsheet. I would also like for the userform to update a set of named ranges (with any new options that come along) in another tab of the workbook. So far, I have a userform set up with comboboxes to automatically fill based on a few named ranges in a separate sheet. Within the Userform, there is a textbox for the user to add a new option if they do not see what they are looking for in the list provided. I would like this textbox to enter the text in the "raw data" sheet and also update the named range it belongs to in the "lookup lists" sheet so that the next time the userform is activated the new option is present.

However, something is not right in my code because the new options are being entered in the first available ROW of the "lookup lists" sheet instead of the first available cell in the appropriate column. Therefore, spaces are being left in some of the columns and the userform is not catching all of the NEW Options the next time it is activated. Wellins CRF Library Project.xls


	VB:
	
 
Private Sub UserForm_Activate() 
    With Application 
        Me.Top = .Top 
        Me.Left = .Left 
        Me.Height = .Height 
        Me.Width = .Width 
    End With 
End Sub 
 
Private Sub UserForm_Initialize() 
    Dim System As Range 
    Dim Sponsor As Range 
    Dim Group As Range 
    Dim KeyWords As Range 
    Dim ws As Worksheet 
    Set ws = Worksheets("LookupLists") 
     'Select options from Comboboxes'
    For Each System In ws.Range("System") 
        With Me.cbo_System 
            .AddItem System.Value 
            .List(.ListCount - 1, 1) = System.Offset(0, 1).Value 
        End With 
    Next System 
    For Each Sponsor In ws.Range("Sponsor") 
        With Me.cbo_Sponsor 
            .AddItem Sponsor.Value 
            .List(.ListCount - 1, 1) = Sponsor.Offset(0, 1).Value 
        End With 
    Next Sponsor 
    For Each KeyWords In ws.Range("Keywords") 
        With Me.cbo_Keywords1 
            .AddItem KeyWords.Value 
            .List(.ListCount - 1, 1) = KeyWords.Offset(0, 1).Value 
        End With 
    Next KeyWords 
    For Each KeyWords In ws.Range("Keywords") 
        With Me.cbo_Keywords2 
            .AddItem KeyWords.Value 
            .List(.ListCount - 1, 1) = KeyWords.Offset(0, 1).Value 
        End With 
    Next KeyWords 
    For Each KeyWords In ws.Range("Keywords") 
        With Me.cbo_Keywords3 
            .AddItem KeyWords.Value 
            .List(.ListCount - 1, 1) = KeyWords.Offset(0, 1).Value 
        End With 
    Next KeyWords 
    For Each KeyWords In ws.Range("Keywords") 
        With Me.cbo_Keywords4 
            .AddItem KeyWords.Value 
            .List(.ListCount - 1, 1) = KeyWords.Offset(0, 1).Value 
        End With 
    Next KeyWords 
    For Each Group In ws.Range("Group") 
        With Me.cbo_Group 
            .AddItem Group.Value 
            .List(.ListCount - 1, 1) = Group.Offset(0, 1).Value 
        End With 
    Next Group 
    For Each Data_Domain In ws.Range("Data_Domain") 
        With Me.cbo_Data_Domain 
            .AddItem Data_Domain.Value 
            .List(.ListCount - 1, 1) = Data_Domain.Offset(0, 1).Value 
        End With 
    Next Data_Domain 
End Sub 
 
Private Sub cmd_Submit_Click() 
    ActiveSheet.Unprotect ("standards") 
    Dim RowCount As Long 
    Dim ctl As Control 
     ' Check user input
    If Trim(Me.cbo_System.Value) & Trim(Me.Txt_NewSystem.Value) = "" Then 
        Me.cbo_System.SetFocus 
        MsgBox "Please enter a System or Add a New system" 
        Exit Sub 
    End If 
    If Trim(Me.cbo_Sponsor.Value) & Trim(Me.txt_NewSponsor.Value) = "" Then 
        Me.cbo_Sponsor.SetFocus 
        MsgBox "Please enter a Sponsor or Add a New Sponsor" 
        Exit Sub 
    End If 
    If Trim(Me.cbo_Keywords1.Value) & Trim(Me.cbo_Keywords2.Value) & Trim(Me.cbo_Keywords3.Value) &
Trim(Me.cbo_Keywords4.Value) & Trim(Me.txt_NewKeyword.Value) = "" Then 
        Me.cbo_Keywords1.SetFocus 
        MsgBox "Please enter at least One (1) Keyword or Add a New Keyword" 
        Exit Sub 
    End If 
    If Trim(Me.cbo_Group.Value) & Trim(Me.txt_NewGroup.Value) = "" Then 
        Me.cbo_Group.SetFocus 
        MsgBox "Please enter a Group or Add a New Group" 
        Exit Sub 
    End If 
    If Trim(Me.cbo_Data_Domain.Value) & Trim(Me.txt_NewDataDomain.Value) = "" Then 
        Me.cbo_Data_Domain.SetFocus 
        MsgBox "Please enter a Data Domain or Add a New Data Domain" 
        Exit Sub 
    End If 
    If Trim(Me.txt_CRFName.Value) = "" Then 
        Me.txt_CRFName.SetFocus 
        MsgBox "Please Name the CRF" 
        Exit Sub 
    End If 
    If Trim(Me.txt_Decription.Value) = "" Then 
        Me.txt_Decription.SetFocus 
        MsgBox "Please enter the CRF Description" 
        Exit Sub 
    End If 
    If Trim(Me.txt_Link.Value) = "" Then 
        Me.txt_Link.SetFocus 
        MsgBox "Please enter the Link to the CRF" 
        Exit Sub 
    End If 
     ' Write data to worksheet
    RowCount = Worksheets("Raw Data").Range("A1").CurrentRegion.Rows.Count 
    With Worksheets("Raw Data").Range("A1") 
        .Offset(RowCount, 0).Value = Me.cbo_System.Value & Me.Txt_NewSystem.Value 
        .Offset(RowCount, 1).Value = Me.cbo_Sponsor.Value & Me.txt_NewSponsor.Value 
        .Offset(RowCount, 2).Value = Me.txt_CRFName.Value 
        .Offset(RowCount, 3).Value = Me.txt_Decription.Value 
        .Offset(RowCount, 4).Value = Me.cbo_Keywords1.Value & ", " & Me.cbo_Keywords2.Value & ", " & Me.cbo_Keywords3.Value &
", " & Me.cbo_Keywords4.Value & ", " & Me.txt_NewKeyword.Value 
        .Offset(RowCount, 5).Value = Me.cbo_Group.Value & Me.txt_NewGroup.Value 
        .Offset(RowCount, 6).Value = Me.cbo_Data_Domain.Value & Me.txt_NewDataDomain.Value 
        .Offset(RowCount, 7).Value = Me.txt_Link.Value = sHypLink 
    End With 
     'copy the new data options to the lookup lists
    RowCount = Worksheets("LookupLists").Range("A1").CurrentRegion.Rows.Count 
    With Worksheets("LookupLists").Range("A1") 
        .Offset(RowCount, 0).Value = Me.Txt_NewSystem.Value 
        .Offset(RowCount, 1).Value = Me.txt_NewSponsor.Value 
        .Offset(RowCount, 4).Value = Me.txt_NewKeyword.Value 
        .Offset(RowCount, 2).Value = Me.txt_NewGroup.Value 
        .Offset(RowCount, 3).Value = Me.txt_NewDataDomain.Value 
    End With 
     ' Clear the form
    For Each ctl In Me.Controls 
        If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then 
            ctl.Value = "" 
        End If 
    Next ctl 
    Unload Me 
    Cells.Find(What:="*", After:=[A8], SearchDirection:=xlPrevious).Select 
    ActiveSheet.Protect ("standards") 
End Sub 
 
Private Sub cmd_Cancel_Click() 
    Unload Me 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Any suggestions will be greatly appreciated...I've been stuck on this for a while now. Thank you SO MUCH!

Hi there!

Anyone interested in merging these THREE macros into one effecient macro? (One pass through the sheets instead of three separate passes?).

This is extremely helpful for reducing file size at my company on existing spreadsheets.

Estimate using these macros along with the zip backup utilitiy (bottom most) saves my company thousands of gigabytes of space.

1-Remove old cache data- (Clears old items from pivot cache..."ghost" items)
Code:
Sub ClearOldItems()
Dim pt As PivotTable
Dim pf As PivotField
Dim pi As PivotItem
Dim strVersion As String
strVersion = Application.Version
Application.ScreenUpdating = False
On Error GoTo errHandler
Dim ws As Worksheet
Set ws = ActiveSheet
  If PivotCheck(ws) Then
    If Val(strVersion) >= 10 Then
      For Each pt In ActiveSheet.PivotTables
        pt.ManualUpdate = True
        pt.PivotCache.MissingItemsLimit = 0
        pt.ManualUpdate = False
      Next pt
    Else
      On Error Resume Next
        For Each pt In ActiveSheet.PivotTables
          pt.RefreshTable
          pt.ManualUpdate = True
          For Each pf In pt.VisibleFields
            If pf.Name  "Data" Then
              For Each pi In pf.PivotItems
                If pi.RecordCount = 0 And _
                  Not pi.IsCalculated Then
                  pi.Delete
                End If
              Next pi
            End If
          Next pf
          pt.ManualUpdate = False
          pt.RefreshTable
        Next pt
    End If
  Else
    MsgBox "There are no pivot tables on the active sheet"
  End If
Application.ScreenUpdating = True
exitHandler:
  Set pi = Nothing
  Set pf = Nothing
  Set pt = Nothing
  Set ws = Nothing
  Application.ScreenUpdating = True
  Exit Sub
errHandler:
  GoTo exitHandler
End Sub

2-Removes duplicate caches (I need to remove the feature of creating a worsheet and using the worksheet, just want it to remove /merge duplicate caches!):
Code:
Sub CheckCaches()
Dim pc As PivotCache
Dim wsList As Worksheet
Dim lRow As Long
Dim lRowPC As Long
Dim pt As PivotTable
Dim ws As Worksheet
Dim lStart As Long
lStart = 2
lRow = lStart
Set wsList = Worksheets.Add
For Each pc In ActiveWorkbook.PivotCaches
  wsList.Cells(lRow, 1).Value = pc.Index
  wsList.Cells(lRow, 2).Value = pc.SourceData
  wsList.Cells(lRow, 3).FormulaR1C1 = _
    "=INDEX(R1C[-2]:R[-1]C[-2],MATCH(RC[-1],R1C[-1]:R[-1]C[-1],0))"
  lRow = lRow + 1
Next pc
For lRowPC = lRow - 1 To lStart Step -1
  With wsList.Cells(lRowPC, 3)
    If IsNumeric(.Value) Then
      For Each ws In ActiveWorkbook.Worksheets
      Debug.Print ws.Name
        For Each pt In ws.PivotTables
        Debug.Print .Offset(0, -2).Value
          If pt.CacheIndex = .Offset(0, -2).Value Then
            pt.CacheIndex = .Value
          End If
        Next pt
      Next ws
    End If
  End With
Next lRowPC
'uncomment lines below to delete the temp worksheet
'Application.DisplayAlerts = False
'wsList.Delete
exitHandler:
Application.DisplayAlerts = True
Exit Sub
errHandler:
MsgBox "Could not change all pivot caches"
Resume exitHandler
End Sub
3-This is Microsoft's version of ExcelDiet to reduce the size of a file based on excel not calculating last row/column correctly-
Code:
Sub ClearExcessRowsAndColumns()
   Dim ar As Range, r As Double, c As Double, tr As Double, tc As Double
   Dim wksWks As Worksheet, ur As Range, arCount As Integer, i As Integer
   Dim blProtCont As Boolean, blProtScen As Boolean, blProtDO As Boolean
   Dim shp As Shape
 
'ToggleEvents False
   On Error Resume Next
   For Each wksWks In ActiveWorkbook.Worksheets
      Err.Clear
      'Store worksheet protection settings and unprotect if protected.
      blProtCont = wksWks.ProtectContents
      blProtDO = wksWks.ProtectDrawingObjects
      blProtScen = wksWks.ProtectScenarios
      wksWks.Unprotect ""
      If Err.Number = 1004 Then
         Err.Clear
         MsgBox "'" & wksWks.Name & _
               "' is protected with a password and cannot be checked." _
               , vbInformation
      Else
         Application.StatusBar = "Checking " & wksWks.Name & ", Please Wait..."
         r = 0
         c = 0
         'Determine if the sheet contains both formulas and constants
         Set ur = Union(wksWks.UsedRange.SpecialCells(xlCellTypeConstants), _
               wksWks.UsedRange.SpecialCells(xlCellTypeFormulas))
         'If both fails, try constants only
         If Err.Number = 1004 Then
            Err.Clear
            Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeConstants)
         End If
         'If constants fails then set it to formulas
         If Err.Number = 1004 Then
            Err.Clear
            Set ur = wksWks.UsedRange.SpecialCells(xlCellTypeFormulas)
         End If
         'If there is still an error then the worksheet is empty
         If Err.Number  0 Then
            Err.Clear
            If wksWks.UsedRange.Address  "$A$1" Then
               ur.EntireRow.Delete
            Else
               Set ur = Nothing
            End If
         End If
         'On Error GoTo 0
         If Not ur Is Nothing Then
            arCount = ur.Areas.Count
            'determine the last column and row that contains data or formula
            For Each ar In ur.Areas
               i = i + 1
               tr = ar.Range("A1").Row + ar.Rows.Count - 1
               tc = ar.Range("A1").Column + ar.Columns.Count - 1
               If tc > c Then c = tc
               If tr > r Then r = tr
            Next
            'Determine the area covered by shapes
            'so we don't remove shading behind shapes
            For Each shp In wksWks.Shapes
               tr = shp.BottomRightCell.Row
               tc = shp.BottomRightCell.Column
               If tc > c Then c = tc
               If tr > r Then r = tr
            Next
            Application.StatusBar = "Clearing Excess Cells in " & _
                  wksWks.Name & ", Please Wait..."
            Set ur = wksWks.Rows(r + 1 & ":" & wksWks.Rows.Count)
               ur.Clear
            'Reset row height which can also cause the lastcell to be innacurate
            ur.EntireRow.RowHeight = _
                  wksWks.StandardHeight
            Set ur = wksWks.Range(wksWks.Cells(1, c + 1), _
                  wksWks.Cells(1, 256)).EntireColumn
            'Reset column width which can also cause the lastcell to be innacurate
            ur.EntireColumn.ColumnWidth = _
                  wksWks.StandardWidth
         End If
      End If
      'Reset protection.
      wksWks.Protect "", blProtDO, blProtCont, blProtScen
      Err.Clear
   Next
   Application.StatusBar = False
'   MsgBox "'" & ActiveWorkbook.Name & _
'         "' has been cleared of excess formatting." & Chr(13) & _
'         "You must save the file to keep the changes.", vbInformation
'ToggleEvents True
End Sub

Backup file with compression (this must be put into a form and rewritten to match your buttons and fields---it saves a copy of your activeworkbook in your active directory into a compressed/zip folder named "_bkp". It also allows you to add optional comments to the backup file):
Code:
Private Sub UserForm_Activate()
Dim lTop As Long, lLeft As Long
Dim lRow As Long, lCol As Long
    With ActiveWindow.VisibleRange
        lRow = .Rows.Count / 2
        lCol = .Columns.Count / 2
    End With
    With Cells(lRow, lCol)
        lTop = .Top
        lLeft = .Left
    End With
    With Me
        .Top = lTop
        .Left = lLeft
    End With
End Sub
Private Sub OKButton_Click()
strComments = ("""" & Me.ZipComments_TextBox.Text & """")
Zip_ActiveWorkbook
Unload frm_ZipSaveComment
End Sub
Private Sub CancelButton_Click()
Unload frm_ZipSaveComment
End Sub
'This sub will make a copy of the Activeworkbook
'and zip it to a bkp zip folder in active workbook directory
Private Sub Zip_ActiveWorkbook()
'ThisWorkbook.BuiltinDocumentProperties("title") = "YourTitle"
ActiveWorkbook.Save
    DefPath = ActiveWorkbook.Path '

Hey all,

I know absolutely nothing about SQL, and was wondering if the following code could be programmed into SQL language. Any help would be much appreciated!

Code:
Sub Highlight_Half_Dupes()
Dim rowx As Long
Dim i As Integer
Dim LR As Long
Dim c As Range
Dim j As Integer
Dim k As Integer
Dim Dup As Integer
Dim RowArray
LR = Range("B" & Rows.count).End(xlUp).row
ReDim RowArray(1 To LR) As String
Dim bool As Boolean
' This part combines all of the data elements into one long string of text.
Cells(2, 17).Formula = "=CONCATENATE(B2,C2,D2,E2,F2,G2,H2,I2,J2,K2,L2,M2,N2,P2)"
Range("Q2").AutoFill Destination:=Range("Q2:Q" & LR), Type:=xlFillDefault
'This part tells Excel to start at the last entry in the spreadsheet and work its way up.
'   The reason Excel needs to start at the bottom and work up is so it captures ALL of the data.
'   Otherwise, the macro wants to highlight EVERY entry in the whole table.
For rowx = LR To 2 Step -1
    Dup = 0
    
    'This finds out if the entry Excel is currently looking at is already in RowArray
    For k = 1 To LR
        If RowArray(k) = Cells(rowx, 17).Value Then
            bool = True
            Exit For
        Else
            bool = False
        End If
    Next k
    
    'This is the controller to determine what excel should do now that it knows if an entry
    ' is duplicated
    Select Case bool
    
    Case True
        'do nothing
    Case False
        'This adds the current entry into RowArray so it isn't looked at again by the macro.
        RowArray(rowx) = Cells(rowx, 17).Value
        
        'This finds out how many times the entry is duplicated.
        For i = 2 To LR
            If Cells(i, 17).Value = Cells(rowx, 17).Value Then Dup = Dup + 1
        Next i
        
        'This finds out if the number of duplicates is divisible by 2.
        If Dup * 0.5 = Round((Dup * 0.5), 0) Then
            Dup = Dup * 0.5
        Else
            Dup = 0
        End If
        
        'This finds one of the duplicate entries, highlights the row, then goes to the next duplicate
        '   entry if more than 2 duplicate entries need to be highlights.
        'Keep in mind, that in the algorithm just above, I changed the number of "Dup" to half
        '   of the original Dup, that way it reflects half of the total duplicates needed to be highlighted.
        With Worksheets(1).Range("Q2:Q" & (rowx - 1))
            Set c = .Find(Cells(rowx, 17).Value, LookIn:=xlValues)
            If Dup > 0 Then
                For j = 1 To Dup
                    If Not c Is Nothing Then
                        Range("A" & c.row).Value = "D"
                        c.EntireRow.Interior.ColorIndex = 5
                        Set c = .FindPrevious(c)
                    End If
                Next j
            Else
            End If
        End With
    End Select
bool = False
Next rowx
End Sub


Hi,

Before I explain my problem, I should let you all know that I posted this same question on another forums, and this is the link to that forum (which it hasn't had an answer yet)

http://www.excelforum.com/showthread.php?t=642781

Also in this forum, where I got some responses to my issue and appreciate them, however I tried many times modifying what they suggested and still doesn't work in my situation.

http://www.ozgrid.com/forum/showthre...691#post431691

I will describe my problem now as clear as possible. I'm making a Task list with assignments for each of my team members. Columns A & B describes the ID number of the task, Column C describes the Task itself, Columns D to J are hidden, Column K describes the author of the task.

Column L is the one that have the name (or names) of the person who is in charge of doing that task. What I need to do is to create a macro that searches the name of that person in Column L and once it finds it it will create another sheet with the name of that person. And add to that sheet the entire row of his task.

For example:
|-----------------------------------------------------------------|
|-A-|-B-|--------C---------|---K---|----L------|
|-----------------------------------------------------------------|
|---1---|-----Project A-----|
|--1.01-|-Approve Invoices--|--Jim--|---Dave---|
|--1.02-|--SCC Agreement---|--Jim--|---Victor--|
|-----------------------------------------------------------------|
|-----------------------blank row---------------------------------|
|-----------------------------------------------------------------|
|---2----|-----Project B-----|
|--2.01--|--Planning meeting-|--Jim--|---Victor--|
|--2.02--|-Database update--|--Jim--|---Victor--|
|--2.03--|-Master agreement-|--Jim--|-Victor, Dave-|
|-----------------------------------------------------------------|

This macro should do rename Sheet2 as 'Dave' and it'd contain:
|-----------------------------------------------------------|
|-A-|-B-|--------C--------|--K--|
|-----------------------------------------------------------|
|---1---|----Project A-----|-----|
|--1.01-|-Approve Invoices-| Jim |
|-----------------------------------------------------------|
|------------------------blank row--------------------------|
|-----------------------------------------------------------|
|---2---|----Project B------|-----|
|--2.03-|-Master agreement-| Jim |
|-----------------------------------------------------------|

Then it should rename Sheet3 as 'Victor' and it'd contain:
|-----------------------------------------------------------------|
|-A-|-B-|--------C----------|---K---|
|---1---|-----Project A------|-------|
|--1.02-|--SCC Agreement---|--Jim--|
|-----------------------------------------------------------------|
|-----------------------------------------------------------------|
|---2----|-----Project B-----|---K---|
|--2.01--|--Planning meeting-|--Jim--|
|--2.02--|-Database update--|--Jim--|
|--2.03--|-Master agreement-|--Jim--|
|-----------------------------------------------------------------|

...and it should do the same for any names in the cells of that column, and each cell can contain up to 3 names separated by a comma. Once I run this macro again it should update the information of each sheet created.

I'm new to macros-vba. I don't understand it much, but I found this code online :
Code:
Sub PagesByDescription()
Dim rRange As Range, rCell As Range
Dim wSheet As Worksheet
Dim wSheetStart As Worksheet
Dim strText As String

    Set wSheetStart = ActiveSheet
    wSheetStart.AutoFilterMode = False
    'Set a range variable to the correct item column
    Set rRange = Range("L9", Range("L65536").End(xlUp))
    
        'Delete any sheet called "UniqueList"
        'Turn off run time errors & delete alert
        On Error Resume Next
        Application.DisplayAlerts = False
        Worksheets("UniqueList").Delete
        
        'Add a sheet called "UniqueList"
        Worksheets.Add().Name = "UniqueList"
        
           'Filter the Set range so only a unique list is created
            With Worksheets("UniqueList")
                rRange.AdvancedFilter xlFilterCopy, , _
                 Worksheets("UniqueList").Range("A1"), True
                 
                 'Set a range variable to the unique list, less the heading.
                 Set rRange = .Range("A2", .Range("A65536").End(xlUp))
            End With
            
            On Error Resume Next
            With wSheetStart
                For Each rCell In rRange
                  strText = rCell
                 .Range("A1").AutoFilter 1, strText
                    Worksheets(strText).Delete
                    'Add a sheet named as content of rCell
                    Worksheets.Add().Name = strText
                    'Copy the visible filtered range _
                    (default of Copy Method) and leave hidden rows
                    .UsedRange.Copy Destination:=ActiveSheet.Range("A1")
                    ActiveSheet.Cells.Columns.AutoFit
                Next rCell
            End With
            
        With wSheetStart
            .AutoFilterMode = False
            .Activate
        End With
        
        On Error GoTo 0
        Application.DisplayAlerts = True
        
End Sub

And I tried this one:

Code:
Sub SearchForString()
     
    Dim LSearchRow As Integer
    Dim LCopyToRow As Integer
     
    On Error GoTo Err_Execute
     
     'Start search in row 4
    LSearchRow = 9
     
     'Start copying data to row 2 in Sheet2 (row counter  variable)
    LCopyToRow = 2
     
    While Len(Range("A" & CStr(LSearchRow)).Value) >= 0
         
         'If value in column E = "Mail Box", copy entire row to Sheet2
        If Range("L" & CStr(LSearchRow)).Value = "Jim" Then
             
             'Select row in Sheet1 to copy
            Rows(CStr(LSearchRow) & ":" & CStr(LSearchRow)).Select
            Selection.Copy
             
             'Paste row into Sheet2 in next row
            Sheets("Sheet2").Select
            Rows(CStr(LCopyToRow) & ":" & CStr(LCopyToRow)).Select
            ActiveSheet.Paste
             
             'Move counter to next row
            LCopyToRow = LCopyToRow + 1
             
             'Go back to Sheet1 to continue searching
            Sheets("Sheet1").Select
             
        End If
         
        LSearchRow = LSearchRow + 1
         
    Wend
     
     'Position on cell A3
    Application.CutCopyMode = False
    Range("A3").Select
     
     MsgBox "All matching data has been copied."
     
    Exit Sub
     
Err_Execute:
    MsgBox "An error occurred."
     
End Sub

I tried this other one:

Code:
Sub GetIt()
    Dim sheetA As Worksheet, sheetB As Worksheet
    Dim wb As Workbook
    Dim i As Long, k As Long
    Set wb = ActiveWorkbook
    Set sheetA = wb.Sheets(1)
     
    i = 9
    On Error Resume Next
    With sheetA
        While Not IsEmpty(.Cells(i, 5).Value)
            Set sheetB = wb.Sheets(.Cells(i, 5))
            If sheetB Is Nothing Then
                wb.Sheets.Add After:=wb.Sheets(wb.Sheets.Count)
                Set sheetB = wb.ActiveSheet
                sheetB.Name = .Cells(i, 5)
                .Rows(2).Copy sheetB.Rows(1)
            End If
            k = sheetB.Range("B65536").End(xlUp).Row + 1
             
            .Rows(i).Copy sheetB.Rows(k)
            i = i + 1
            Set sheetB = Nothing
        Wend
    End With
End Sub
And I just tried this last one:

Code:
Sub ExtractToSheets()
    Dim ws     As Worksheet
    Dim wsNew  As Worksheet
    Dim rData  As Range
    Dim rCl    As Range
    Dim sNm    As String
    Set ws = Worksheets("Sheet1")
    Set rData = ws.Range("a1", ws.Range("z65536").End(xlUp))
     
     'extract a list of unique names
    ws.Range("L9", Range("l65536").End(xlUp)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("i1"), Unique:=True
     
    For Each rCl In ws.Range("i1", ws.Range("i65536").End(xlUp))
        sNm = rCl.Text
         'add new sheet (only if required-NB uses  UDF)
        If WksExists(sNm) Then
            Sheets(sNm).Cells.Clear
        Else
            Set wsNew = Sheets.Add
            wsNew.Move After:=Worksheets(Worksheets.Count) 'move to end
            wsNew.Name = sNm
        End If
         'AutoFilter & copy to relevant sheet
        rData.AutoFilter Field:=2, Criteria1:=sNm
        rData.Copy Destination:=Worksheets(sNm).Range("a1")
    Next rCl
    ws.Columns(9).Delete 'remove temporary list
    rData.AutoFilter 'switch off AutoFilter
End Sub
Function WksExists(wksName As String) As Boolean
    On Error Resume Next
    WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function
I'm new to Excel macros-vba, I'm trying to modify any of this codes to work for my problem, but I cannot seem to achieve it. Also, if the code encounter in a the cell more than one name (e.g. Victor,Mike,Jim) instead of copying that row of information to their respective individual sheets, it creates a sheet with those names, and pastes all information there, and that's not what I want.
Here is the link to the file of the Task List itself for your assistance in helping me.

http://cid-d22788d315f0fa0a.skydrive...se.aspx/Public

Thank you in advance for your help.

After about a year and a half in this forum, I have found the most common question to be... How can I count or sum multiple criteria. Like Countif or Sumif, but having 2 or more columns with criteria. So I thought I'd take some time to write out an explaination. This is going to be long winded. I'm going to try to go into the greatest detail I can.

We'll first need to understand the basic function of Sumproduct. How it is intended to be used.

******** ******************** ************************************************************************>Microsoft Excel - Personal.xls___Running: 11.0 : OS = Windows XP (F)ile (E)dit (V)iew (I)nsert (O)ptions (T)ools (D)ata (W)indow (H)elp (A)boutD2E2F2D3D4D5D6D7D8D9D10=
ABCDEF1Val1Val2 Val1 * Val2Sum of DSumproduct2220 40384038403330 90  4440 160  5550 250  6660 360  7770 490  8880 640  9990 810  1010100 1000  Sheet2 
[HtmlMaker 2.42] To see the formula in the cells just click on the cells hyperlink or click the Name box
PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR.

In D2 I've put your basic Multiplication formula
=A2*B2 and filled down to row 10
In E2 is
=SUM(D2:D10)

Sumproduct does that for you in 1 formula
Sumproduct SUMS the Product of Each argument(seperated by commas).

in F2
=SUMPRODUCT(A2:A10,B2:B10)

You should see E2 and F2 have the same result.

How it works...
It reads the formula 1 row at a time.
So starting in row 2, it multiplies A2*B2 = 40
Now to row 3, it multiplies A3*B3 = 90
Now to row 4, it multiplies A4*B4 = 160
etc...
That is the PRODUCT part of SUMPRODUCT.

THEN it ADDS all the results from each row.
that is the SUM part of SUMPRODUCT.

That is the basic intended purpose of SUMPRODUCT

Now, how does that help us with Multiple Critera Count/Sum...

We'll start with COUNT

Now look at this example sheet

******** ******************** ************************************************************************>Microsoft Excel - Personal.xls___Running: 11.0 : OS = Windows XP (F)ile (E)dit (V)iew (I)nsert (O)ptions (T)ools (D)ata (W)indow (H)elp (A)boutE5E8=
ABCDEF1NameProductCost MakerProduct2FordCar12713 ChevyCar3ChevyTruck10816   4ChevyVan10503 COUNT 5FordCar11552 3 6ChevyCar13887   7FordTruck10451 SUM 8ChevyCar14579 42001 9FordVan11395   10ChevyCar13535   Sheet1 
[HtmlMaker 2.42] To see the formula in the cells just click on the cells hyperlink or click the Name box
PLEASE DO NOT QUOTE THIS TABLE IMAGE ON SAME PAGE! OTHEWISE, ERROR OF JavaScript OCCUR.

Take the formula in E5
=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2))

The formula is devided into 2 sections(or arguments seperated by commas)

--(A2:A10=E2)
--(B2:B10=F2)

These are QUESTIONS, also called EXPRESSIONS.
They each result in TRUE or FALSE.
Remember that it reads the formula 1 row at a time.

Does the value in A2 = The value in E2 ? TRUE or FALSE ?
Does the value in B2 = The value in F2 ? TRUE or FALSE ?

But SUMPRODUCT needs NUMERICAL entries, not Text or TRUE/FALSE..
That's where the -- comes in.

In Excel, TRUE = 1 and FALSE = 0
So that formula can be broken down like this (using Row 2 as example)
Does A2 = E2 ? FALSE
Does B2 = F2 ? TRUE
so the formula is translated from
=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2))
to
=SUMPRODUCT(--(FALSE),--(TRUE))

The -- converts TRUE to 1 and FALSE to 0
so the formula is further translated to
=SUMPRODUCT(--(0),--(1))
and that also removes the -- and extra brackets
=SUMPRODUCT(0,1)
So now Row 2 is
0 * 1 = 0

Now moves to Row 3
Does A3 = E3 ? FALSE
Does B3 = F3 ? TRUE
so the formula is translated from
=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2))
to
=SUMPRODUCT(--(TRUE),--(FALSE))

The -- converts TRUE to 1 and FALSE to 0
so the formula is further translated to
=SUMPRODUCT(--(1),--(0))
and that also removes the -- and extra brackets
=SUMPRODUCT(1,0)
So now Row 3 is
1 * 0 = 0

And it continues down each row.
Each row has only 2 possible results.
1 or 0
Because, sumproduct multiplies each argument.
x * x * x etc...
if ANY of those #s are 0, the result is 0
If ALL of those #s are 1, the result is 1

Then after it has done that to all rows,
it then SUMS the result of each row.

In the example from the above table..
only rows 6 8 and 10 would result in 1, all others result in 0.
I'll break down each row

=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2))

One row at a time

Row 2) SUMPRODUCT(--(A2=E2),--(B2=F2))
Row 3) SUMPRODUCT(--(A3=E2),--(B3=F2))
Row 4) SUMPRODUCT(--(A4=E2),--(B4=F2))
Row 5) SUMPRODUCT(--(A5=E2),--(B5=F2))
Row 6) SUMPRODUCT(--(A6=E2),--(B6=F2))
Row 7) SUMPRODUCT(--(A7=E2),--(B7=F2))
Row 8) SUMPRODUCT(--(A8=E2),--(B8=F2))
Row 9) SUMPRODUCT(--(A9=E2),--(B9=F2))
Row 10) SUMPRODUCT(--(A10=E2),--(B10=F2))

Converted to TRUE/FALSE

Row 2) SUMPRODUCT(--(FALSE),--(TRUE))
Row 3) SUMPRODUCT(--(TRUE),--(FALSE))
Row 4) SUMPRODUCT(--(TRUE),--(FALSE))
Row 5) SUMPRODUCT(--(FALSE),--(TRUE))
Row 6) SUMPRODUCT(--(TRUE),--(TRUE))
Row 7) SUMPRODUCT(--(FALSE),--(FALSE))
Row 8) SUMPRODUCT(--(TRUE),--(TRUE))
Row 9) SUMPRODUCT(--(FALSE),--(FALSE))
Row 10) SUMPRODUCT(--(TRUE),--(TRUE))

Converted to 1/0 with --

Row 2) SUMPRODUCT(0,1)
Row 3) SUMPRODUCT(1,0)
Row 4) SUMPRODUCT(1,0)
Row 5) SUMPRODUCT(0,1)
Row 6) SUMPRODUCT(1,1)
Row 7) SUMPRODUCT(0,0))
Row 8) SUMPRODUCT(1,1)
Row 9) SUMPRODUCT(0,0)
Row 10) SUMPRODUCT(1,1)

Simplest Math Expression

Row 2) 0 * 1 = 0
Row 3) 1 * 0 = 0
Row 4) 1 * 0 = 0
Row 5) 0 * 1 = 0
Row 6) 1 * 1 = 1
Row 7) 0 * 0 = 0
Row 8) 1 * 1 = 1
Row 9) 0 * 0 = 0
Row 10) 1 * 1 = 1

Summed together
0+0+0+0+1+0+1+0+1 = 3

I hope that makes sense, and I haven't missed anything...

To make this a SUM instead of count, simply add the SumRange at the end.
See Formula in E8
=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2),C2:C10)

the last argument C2:C10 is not an expression, it's just a number.
so no -- is needed. Now the result of that row, will be the result
of the questions * value in C..

I'll break that down 1 row at a time again

=SUMPRODUCT(--(A2:A10=E2),--(B2:B10=F2),C2:C10)

One row at a time

Row 2) SUMPRODUCT(--(A2=E2),--(B2=F2),C2)
Row 3) SUMPRODUCT(--(A3=E2),--(B3=F2),C3)
Row 4) SUMPRODUCT(--(A4=E2),--(B4=F2),C4)
Row 5) SUMPRODUCT(--(A5=E2),--(B5=F2),C5)
Row 6) SUMPRODUCT(--(A6=E2),--(B6=F2),C6)
Row 7) SUMPRODUCT(--(A7=E2),--(B7=F2),C7)
Row 8) SUMPRODUCT(--(A8=E2),--(B8=F2),C8)
Row 9) SUMPRODUCT(--(A9=E2),--(B9=F2),C9)
Row 10) SUMPRODUCT(--(A10=E2),--(B10=F2),C10)

Converted to TRUE/FALSE (and putting in the number from C)

Row 2) SUMPRODUCT(--(FALSE),--(TRUE),12713)
Row 3) SUMPRODUCT(--(TRUE),--(FALSE),10816)
Row 4) SUMPRODUCT(--(TRUE),--(FALSE),10503)
Row 5) SUMPRODUCT(--(FALSE),--(TRUE),11552)
Row 6) SUMPRODUCT(--(TRUE),--(TRUE),13887)
Row 7) SUMPRODUCT(--(FALSE),--(FALSE),10451)
Row 8) SUMPRODUCT(--(TRUE),--(TRUE),14579)
Row 9) SUMPRODUCT(--(FALSE),--(FALSE),11395)
Row 10) SUMPRODUCT(--(TRUE),--(TRUE),13535)

Converted to 1/0 with --

Row 2) SUMPRODUCT(0,1,12713)
Row 3) SUMPRODUCT(1,0,10816)
Row 4) SUMPRODUCT(1,0,10503)
Row 5) SUMPRODUCT(0,1,11552)
Row 6) SUMPRODUCT(1,1,13887)
Row 7) SUMPRODUCT(0,0),10451)
Row 8) SUMPRODUCT(1,1,14579)
Row 9) SUMPRODUCT(0,0,11395)
Row 10) SUMPRODUCT(1,1,13535)

Simplest Math Expression

Row 2) 0 * 1 * 12713= 0
Row 3) 1 * 0 * 10816= 0
Row 4) 1 * 0 * 10503 = 0
Row 5) 0 * 1 * 11552 = 0
Row 6) 1 * 1 * 13887 = 13887
Row 7) 0 * 0 * 10451 = 0
Row 8) 1 * 1 * 14579 = 14579
Row 9) 0 * 0 * 11395 = 0
Row 10) 1 * 1 * 13535 = 13535

Summed together
0+0+0+0+13887+0+14579+0+13535 = 42001

That pretty much wraps it up. You can add MANY criteria,
just add another section seperated by a comma using format
--(Range=Criteria)

You would be limited to 30 criteria for COUNT, 29 for SUM.

You can use other operators, like < > or for NOT equal.

You can put other functions inside the expressions, as long as
the result is TRUE false...

Like --(LEFT(A1:A10,1)="F")

that works fine, as long as the expression returns TRUE or FALSE.

Hi,

I'm back with my little bug reporting tool and now I would like to know how I populate a form with values from a row in my excel sheet that i selected in a multicolumn textbox.

My "tool" works like this... The user opens the excel file and can choose one of two buttons, Add defect and Find defect. When the Add button is clicked Form1 is opened and the user fills in a number of fields which are then inserted into an excel sheet (same book though). Then there's the Find button. When the user clicks this button Form2 opens with a multicolumn textbox that displays some of the columns with some of the previously inserted information. Now I would like to be able to select one row and get Form1 populated with the values for that particular row. The user should then be able to change some of the values and the changes should be inserted back into the correct row in my excel sheet. How in the world do I do this??? Right now I just open my Form1 when I select a row and click an OK button. How do I get the values from my excel sheet back into my fields?I've tried to copy code from an example I found, but I can't get it to work.

My first form where I add my data
Code:
Private Sub UserForm1_Initialize()
Dim rIds As Range
Dim MaxId As Long

Set rIds = Worksheets("Systemtest").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
MaxId = Application.WorksheetFunction.Max(rIds)
With Me
.IdBox.Value = MaxId


Private Sub DateBox_Change()
   DateBox = Format(Date, "yy/mm/dd")
End Sub

Private Sub HeadingBox_Change()

End Sub

Private Sub IdBox_Change()
'   =IF(COUNTA(Systemtest[1]:Systemtest[1])=1,COUNTA(Systemtest[1]:Systemtest[1]),"""")

End Sub



Private Sub StatusBox_Change()
    StatusBox.List = Array("New", "Open", "In Progress", "Fixed", "Closed", "Reopen", "Rejected", "Pending")
'    StatusBox.Value = "New"
End Sub

Private Sub SeverityBox_Change()
    SeverityBox.List = Array("Critical", "Major", "Normal", "Minor", "Cosmetic", "Improvement")
'    SeverityBox.Value = "Normal"
End Sub

Private Sub EnvBox_Change()
    EnvBox.List = Array("NLL", "JLL", "NLL/JLL", "Halland")
'    SeverityBox.Value = "NLL"
End Sub

Private Sub SummaryBox_Change()

End Sub

Private Sub VersionBox_Change()
    VersionBox.List = Array("3.5.aa.1", "3.5.aa.2", "3.5.aa.3", "3.5.aa.4", "3.5.ab.1")
'    SeverityBox.Value = "3.5.aa.1"
End Sub

Private Sub SubsysBox_Change()
    SubsysBox.List = Array("Ankomstreg (÷,S)", "Diagnosreg", "Generella", _
    "IVA", "Infektionsreg", "Integration", "Journal", "LAB", "Lškemedel", "Lškarintyg/utl", _
    "Operation", "PAS Generella", "Pako", "Paramedicin", "Patient", "Remisser", "RŲntgen", "System", _
    "TandvŚrdsadm", "VŚrddok", "VŚrdkontakt")
'    SubsysBox.Value = "Generella"
End Sub

Private Sub FormBox_Change()

End Sub

Private Sub TesterBox_Change()
    TesterBox.List = Array("ast", "bng", "dll", "esi", "ewalun", "frea", "jfn", "kata", "larb", "lln", "mem", "mhd", "mlm",
"moae", "mwn", "ulwi")
'    TesterBox.Value = "ast"
End Sub

Private Sub ResponsibleBox_Change()
    ResponsibleBox.List = Array("ast", "dll", "esi", "frea", "hkn", "jfn", "kata", "larb", "lln", "mem", "mhd", "mlm",
"moae", "mwn", "ulwi")
'    ResponsibleBox.Value = "ast"
End Sub

Private Sub FixedVerBox_Change()
    FixedVerBox.List = Array("3.5.aa.2", "3.5.aa.3", "3.5.aa.4", "3.5.ab.1", "3.5.ab.2")
'    FixedVerBox.Value = "3.5.aa.2"
End Sub
Private Sub CommentsBox_Change()

End Sub

Private Sub ClosingBox_Change()
    ClosingBox = Format(Date, "yy/mm/dd")
End Sub


Private Sub OKButton_Click()
'   Make sure Systemtest is active
    Sheets("Systemtest").Activate
    
'   Determine the next empty row
    NextRow = _
        Application.WorksheetFunction.CountA(Range("A:A")) + 1
'   Transfer the information
    Cells(NextRow, 1) = IdBox
    Cells(NextRow, 2) = DateBox
    Cells(NextRow, 3) = StatusBox
    Cells(NextRow, 4) = ClosingBox
    Cells(NextRow, 5) = HeadingBox
    Cells(NextRow, 6) = SummaryBox
    Cells(NextRow, 7) = CommentsBox
    Cells(NextRow, 8) = TestspecBox
    Cells(NextRow, 9) = SeverityBox
    Cells(NextRow, 10) = EnvBox
    Cells(NextRow, 11) = VersionBox
    Cells(NextRow, 12) = SubsysBox
    Cells(NextRow, 13) = FormBox
    Cells(NextRow, 14) = TesterBox
    Cells(NextRow, 15) = ResponsibleBox
    Cells(NextRow, 16) = FixedVerBox
    
    
    
    
    
'   Clear the controls for the next entry
    IdBox.Text = ""
    StatusBox.Text = ""
    HeadingBox.Text = ""
    SummaryBox.Text = ""
    CommentsBox.Text = ""
    SeverityBox.Text = ""
    EnvBox.Text = ""
    VersionBox.Text = ""
    SubsysBox.Text = ""
    FormBox.Text = ""
    TestspecBox.Text = ""
'   TesterBox.Text = ""
    ResponsibleBox.Text = ""
    FixedVerBox.Text = ""
    ClosingBox.Text = ""
        
    OptionUnknown = True
    StatusBox.SetFocus
End Sub
Private Sub RegNewButton_Click()

End Sub
Private Sub CancelButton_Click()
    Unload UserForm1
End Sub
My second form where I have my multicolumn textbox and where I'm suppose to select a row and get Form1 displayed with all data for a particular row
Code:
Private Sub UserForm_Initialize()
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim r As Integer
    
    Set Sh = Worksheets("Systemtest")
    With Sh
        Set Rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    r = 0
    For Each Cell In Rng
        With Cell
            ListBox1.AddItem .Value
            ListBox1.List(r, 1) = .Offset(0, 1).Value
            ListBox1.List(r, 2) = .Offset(0, 2).Value
            ListBox1.List(r, 3) = .Offset(0, 4).Value
            ListBox1.List(r, 4) = .Offset(0, 5).Value
            ListBox1.List(r, 5) = .Offset(0, 7).Value
            ListBox1.List(r, 6) = .Offset(0, 12).Value
            ListBox1.List(r, 7) = .Offset(0, 14).Value
            ListBox1.List(r, 8) = .Offset(0, 13).Value
            ListBox1.List(r, 9) = .Offset(0, 15).Value
          End With
        r = r + 1
    Next Cell
End Sub

Private Sub Frame1_Click()

End Sub

Private Sub ListBox1_Click()

End Sub


Private Sub OKButton2_Click()
    UserForm1.Show
    Dim FirstId As String
    Dim strFind As String   'what to find
    Dim rSearch As Range    'what range to search
    Dim fndA, fndB, fndC, fndD, fndE, fndF, fndG, fndH, fndI, fndJ, fndK, fndL, fndM, fndN, fndO, fndP As String
    Dim head1, head2, head3, head4, head5, head6, head7, head8, head9, head10, head11, head12, head13, head14, head15, head16
'headings for list
    Dim i As Integer
    i = 1
    Set rSearch = Systemtest.Range("a2", Range("a65536").End(x1Up))
    Str.Find = Me.TextBox1.Value
    With rSearch = Systemtest.Range
        Set c = .Find(strFind, LookIn:=xlValues)
        If Not c Is Nothing Then    'found it
            c.Select
            'load the headings
            head1 = Range("a2").Value
            head2 = Range("b2").Value
            head3 = Range("c2").Value
            head4 = Range("d2").Value
            head5 = Range("e2").Value
            head6 = Range("f2").Value
            head7 = Range("g2").Value
            head8 = Range("h2").Value
            head9 = Range("i2").Value
            head10 = Range("j2").Value
            head11 = Range("k2").Value
            head12 = Range("l2").Value
            head13 = Range("m2").Value
            head14 = Range("n2").Value
            head15 = Range("o2").Value
            head16 = Range("p2").Value
            
            With Me.ListBox1
                MyArray(0, 0) = head1
                MyArray(0, 1) = head2
                MyArray(0, 2) = head3
                MyArray(0, 3) = head4
                MyArray(0, 4) = head5
                MyArray(0, 5) = head6
                MyArray(0, 6) = head7
                MyArray(0, 7) = head8
                MyArray(0, 8) = head9
                MyArray(0, 9) = head10
                MyArray(0, 10) = head11
                MyArray(0, 11) = head12
                MyArray(0, 12) = head13
                MyArray(0, 13) = head14
                MyArray(0, 14) = head15
                MyArray(0, 15) = head16
             End With
             FirstId = c.Id
             Do
                'Load details into Listbox
                fndA = c.Value
                fndB = c.Offset(0, 1).Value
                fndC = c.Offset(0, 2).Value
                fndD = c.Offset(0, 3).Value
                fndE = c.Offset(0, 4).Value
                fndF = c.Offset(0, 5).Value
                fndG = c.Offset(0, 6).Value
                fndH = c.Offset(0, 7).Value
                fndI = c.Offset(0, 8).Value
                fndJ = c.Offset(0, 9).Value
                fndK = c.Offset(0, 10).Value
                fndL = c.Offset(0, 11).Value
                fndM = c.Offset(0, 12).Value
                fndN = c.Offset(0, 13).Value
                fndO = c.Offset(0, 14).Value
                fndP = c.Offset(0, 15).Value
                
                MyArray(i, 0) = fndA
                MyArray(i, 1) = fndB
                MyArray(i, 2) = fndC
                MyArray(i, 3) = fndD
                MyArray(i, 4) = fndE
                MyArray(i, 5) = fndF
                MyArray(i, 6) = fndG
                MyArray(i, 7) = fndH
                MyArray(i, 8) = fndI
                MyArray(i, 9) = fndJ
                MyArray(i, 10) = fndL
                MyArray(i, 11) = fndM
                MyArray(i, 12) = fndN
                MyArray(i, 13) = fndO
                MyArray(i, 14) = fndP
                i = i + 1
                Set c = .FindNext(c)
                End If
            End With
            'Load data into LISTBOX
            Me.ListBox1.List() = MyArray
End Sub
            
                

Private Sub CancelButton2_Click()
Unload UserForm2
End Sub

Private Sub UserForm_Click()

End Sub
As you probably can see from my code... I'm completely lost and I haven't got a clue what I'm doing.

I have encountered a seemingly impossible occurance (simply because I can't figure out where I've gone wrong).

I've been working on a patient list for the hospital I'm at and, with the help of everyone here on the board, I've managed to write a pretty workable code with some innovative error handling. Thank you Mr Excel for all your help.

Here's my new problem:

I'm trying to create a way to sort the new additions to the patient list by Room Number (one of the criteria entered on my userform under the "txtRoom" text box).

The patient information is entered starting from row 22 (in cloumns A through J) in 2-row blocks. For example, the admission time enters into A22, the admission date into A23; the patient name in B22, the patient date of birth into B23, etc. The last six columns (E through J) are merged into three cells basically, across both rows, i.e. E22:G23 are merged, H22:I23 are merged and J22:J23 are merged.

In order to sort patients, I've been trying to write a loop using For-Next structure that reads the Patient Room number (D22, D24, D26 etc.), finds when the new patient's room number is higher on the list and then basically inserts two new rows above the patient information of the lower room number to insert the new patient's information.

A little confusing, I know, but I've been testing the loop in my code and everytime I try to use the loop, it always stops at the row number 26.

I have no idea why it's doing this. I make sure all the room numbers in my test run are in order, I tried using different test room numbers for the new patient I'm adding, I try using different loop structures, but it always stops at 26!! If I use a room number that is higher than the first two patients (i.e. D22 and D24 cells with room number information), it works and it locates the highest either at D22 or D24. But with any other number to check further down, it just stops at 26.

This is the code for the button that adds a new patient, I'd appreciate any input you can provide. The 'SlipIn' variable is set to determine the row number corresponding to where the new patient would be added.

Thanks

Joe.

Code:
Private Sub cmdAdd_Click()
    Dim Ans As Integer
    Dim iRow As Long
    Dim Today As Date
    Dim Gender As String
    Dim Ethnicity As String
    Dim Age As Integer
    Dim TOA As Date
    Dim DOA As Variant
    Dim Intern As String
    Dim ws As Worksheet
    Dim AddType As String
    Dim SlipIn As Integer
    Application.ScreenUpdating = False
' Prompts user to select Admit Type if not selected
    If cboAdmitType.Value = "" Then
        MsgBox "Please enter the Admission Type."
        Exit Sub
 
' Prompts user to confirm that an old patient will not be counted as a new addition to the team list
' then prompts them to change the admit type if this is not acceptable
    ElseIf cboAdmitType.Value = "Old Patient" Then
        Ans = MsgBox("This patient will not be counted as a new addition." _
            & vbCr & "Is this acceptable?", vbYesNo, "Old Patient - Confirm")
        If Ans = vbNo Then
            MsgBox "Please change Admit Type"
            Exit Sub
        ElseIf Ans = vbYes Then
            DOA = InputBox("Please enter the date of admission for this old patient", "Date of Admit of Old Patient")
            If Not IsDate(DOA) Then
                MsgBox "Please enter a proper date value"
                Exit Sub
            End If
        End If
    End If
 
' Sets time of admission (TOA) value
    TOA = Me.cboHour.Value & ":" & Me.cboMin.Value & Me.cboAmPm.Value
 
' Set worksheet variable to Team list
    Set ws = ActiveSheet
 
' selects the first empty row on the page
    iRow = ws.Cells(Rows.Count, 2).End(xlUp).Offset(1, 0).Row
 
' These prompt the user to fill in text box values if left empty
    If Trim(Me.txtFName.Value) = "" Then
        Me.txtFName.SetFocus
        MsgBox "Please enter patient's First Name"
        Exit Sub
    ElseIf Trim(Me.txtLName.Value) = "" Then
        Me.txtLName.SetFocus
        MsgBox "Please enter patient's Last Name"
        Exit Sub
    ElseIf Trim(Me.txtAcct.Value) = "" Then
        Me.txtAcct.SetFocus
        MsgBox "Please enter Account Number (Acct No.)"
        Exit Sub
    ElseIf Trim(Me.txtMRN.Value) = "" Then
        Me.txtMRN.SetFocus
        MsgBox "Please enter Medical Record Number (MRN)"
        Exit Sub
    ElseIf Trim(Me.cboMonth.Value) = "" Then
        Me.cboMonth.SetFocus
        MsgBox "Please complete patient's Date of Birth"
        Exit Sub
    ElseIf Trim(Me.cboDay.Value) = "" Then
        Me.cboDay.SetFocus
        MsgBox "Please complete patient's Date of Birth"
        Exit Sub
    ElseIf Trim(Me.cboYear.Value) = "" Then
        Me.cboYear.SetFocus
        MsgBox "Please complete patient's Date of Birth"
        Exit Sub
    ElseIf cboAdmitType.Value = "Admission" Then
        If Trim(Me.cboHour.Value) = "" Then
            Me.cboHour.SetFocus
            MsgBox "Please complete Time of Admission"
            Exit Sub
        ElseIf Trim(Me.cboMin.Value) = "" Then
            Me.cboMin.SetFocus
            MsgBox "Please complete Time of Admission"
            Exit Sub
        ElseIf Trim(Me.cboAmPm.Value) = "" Then
            Me.cboAmPm.SetFocus
            MsgBox "Please complete Time of Admission"
            Exit Sub
        End If
    ElseIf Trim(Me.txtRoom.Value) = "" Then
        Me.txtRoom.SetFocus
        MsgBox "Please enter Room (if patient still in ER, please enter ER location)"
        Exit Sub
    ElseIf Trim(Me.txtDiag.Value) = "" Then
        Me.txtDiag.SetFocus
        MsgBox "Please enter Diagnosis"
        Exit Sub
    End If
' Sets Gender variable depending on choice, or prompts user to select one if empty
    If optMale.Value = True Then
        Gender = "M"
    ElseIf optFemale.Value = True Then
        Gender = "F"
    Else
        MsgBox "Please choose a gender"
        Exit Sub
    End If
' Sets Ethnicity variable depending on choice, or prompts user to select one if empty
    If optWhite.Value = True Then
        Ethnicity = "W"
    ElseIf optBlack.Value = True Then
        Ethnicity = "B"
    ElseIf optHisp.Value = True Then
        Ethnicity = "H"
    ElseIf optAsian.Value = True Then
        Ethnicity = "A"
    ElseIf optOther.Value = True Then
        Ethnicity = ""
    Else
        MsgBox "Please select an ethnicity"
        Exit Sub
    End If
' Inserts a new row, formats the borders and the text then inserts the appropriate values
    ' (Test) - loop for determining where to place new patient
 
    For SlipIn = 22 To iRow Step 2
        If txtRoom.Value > Range("D" & SlipIn).Value Then
            Exit For
        End If
    Next SlipIn
 
    MsgBox iRow
    MsgBox SlipIn
    Exit Sub
    Range("A" & iRow, "A" & iRow + 1).Rows.EntireRow.Insert
    Range("E" & iRow, "G" & iRow + 1).Merge
    Range("H" & iRow, "I" & iRow + 1).Merge
    Range("J" & iRow, "J" & iRow + 1).Merge
    With Range("E" & iRow, "I" & iRow + 1)
        .HorizontalAlignment = xlHAlignCenter
        .VerticalAlignment = xlVAlignTop
        .WrapText = True
    End With
    With Range("A" & iRow, "J" & iRow + 1)
        .Font.Size = 7
    End With
    If cboAdmitType.Value  "Old Patient" Then
        With Range("A" & iRow, "J" & iRow + 1)
            .Font.Bold = True
        End With
    End If
 
    If cboAdmitType.Value = "Admission" Then
        ws.Cells(iRow, 1).Value = TOA
    ElseIf cboAdmitType.Value = "Transfer" Then
        ws.Cells(iRow, 1).Value = "TRANS"
    ElseIf cboAdmitType.Value = "Consult" Then
        ws.Cells(iRow, 1).Value = "CONS"
    ElseIf cboAdmitType.Value = "Bounce-Back" Then
        ws.Cells(iRow, 1).Value = "BB"
    ElseIf cboAdmitType.Value = "Old Patient" Then
        ws.Cells(iRow, 1).Value = "OLD"
    End If
 
    If cboAdmitType = "Old Patient" Then
        ws.Cells(iRow + 1, 1).Value = DOA
    Else
        ws.Cells(iRow + 1, 1).Value = WorksheetFunction.Text(Date, "m/d/yy")
    End If
    ws.Cells(iRow, 2).Value = WorksheetFunction.Proper(Me.txtLName.Value & ", " & Me.txtFName.Value)
    ws.Cells(iRow + 1, 2).Value = Me.cboMonth.Value & "/" & Me.cboDay.Value & "/" & Me.cboYear.Value
    Age = Year(Date) - Year(ws.Cells(iRow + 1, 2).Value)
    ws.Cells(iRow, 3).Value = WorksheetFunction.Text(Me.txtMRN.Value, "000-000-000")
    ws.Cells(iRow + 1, 3).Value = Me.txtAcct.Value
    ws.Cells(iRow, 4).Value = Me.txtRoom.Value
    ws.Cells(iRow + 1, 4).Value = Me.txtInt.Value
    ws.Cells(iRow, 5).Value = Age & " yr old " & Ethnicity & Gender & " with " & Me.txtDiag.Value
    ws.Cells(iRow, 8).Value = Me.txtToDo.Value
    ws.Cells(iRow, 10).Value = Me.txtRoom.Value
    Range("J" & iRow).Font.Color = RGB(255, 255, 255)
 
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlEdgeBottom)
        .LineStyle = xlDouble
    End With
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlMedium
    End With
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlEdgeRight)
        .LineStyle = xlDouble
    End With
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlEdgeLeft)
        .LineStyle = xlDouble
    End With
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
    With Range("A" & iRow, "J" & iRow + 1).Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .Weight = xlThin
    End With
' Sets the worksheet variable to Tracker
    Set ws = Worksheets("Tracker")
 
' selects the last non-empty row on the page
 
    iRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
 
' Increases the count by one for whichever admit type is chosen on the tracker worksheet
' and checks the time of admission (TOA) for each admission on call days
    If cboAdmitType.Value = "Admission" Then
        ws.Cells(iRow, 3).Value = ws.Cells(iRow, 3).Value + 1
    ElseIf cboAdmitType.Value = "Transfer" Then
        ws.Cells(iRow, 4).Value = ws.Cells(iRow, 4).Value + 1
    ElseIf cboAdmitType.Value = "Consult" Then
        ws.Cells(iRow, 5).Value = ws.Cells(iRow, 5).Value + 1
    ElseIf cboAdmitType.Value = "Bounce-Back" Then
        ws.Cells(iRow, 6).Value = ws.Cells(iRow, 6).Value + 1
    End If
 
' This adds the admissions to the Admission tracker portion of the Census worksheet.
' It allows tracking of times of admissions based on resident input.
 
    If cboAdmitType.Value = "Admission" Then
        Select Case TimeValue(TOA)
            Case TimeValue("08:00") To TimeValue("11:59")
                ws.Cells(iRow, 12).Value = ws.Cells(iRow, 12).Value + 1
            Case TimeValue("12:00") To TimeValue("15:59")
                ws.Cells(iRow, 13).Value = ws.Cells(iRow, 13).Value + 1
            Case TimeValue("16:00") To TimeValue("19:59")
                ws.Cells(iRow, 14).Value = ws.Cells(iRow, 14).Value + 1
            Case TimeValue("20:00") To TimeValue("23:59")
                ws.Cells(iRow, 15).Value = ws.Cells(iRow, 15).Value + 1
            Case TimeValue("00:00") To TimeValue("03:59")
                ws.Cells(iRow, 16).Value = ws.Cells(iRow, 16).Value + 1
            Case TimeValue("04:00") To TimeValue("07:59")
                ws.Cells(iRow, 17).Value = ws.Cells(iRow, 17).Value + 1
        End Select
    End If
 
    Unload Me
 
    Application.ScreenUpdating = True
 
End Sub


I put together alot of different Macros to make this one. It works great except, it takes about 30 seconds to run. Is there any place where it can be simplified to run faster?

Anyones help would be greatly appreciated....

Code:
Sub SaveWorkSheetAs()

    On Error Resume Next
    Dim NewFileName
    
    NewFileName = ActiveWorkbook.Path & "RFQ " & _
                Worksheets("Quote").Range("b1").Value & " " & _
                Worksheets("Quote").Range("n3").Value & " " & _
                Format(Date, "mmddyy") & " " & Format(Time, "hhmmss") & ".xls"

    Dim Source As Range
    Dim Dest As Workbook
    Dim wb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim OutApp As Object
    Dim OutMail As Object
 
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
 
    If Source Is Nothing Then
        MsgBox "The source is not a range or the sheet is protected, please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
        MsgBox "An Error occurred :" & vbNewLine & vbNewLine & _
               "You have more than one sheet selected." & vbNewLine & _
               "You only selected one cell." & vbNewLine & _
               "You selected more than one area." & vbNewLine & vbNewLine & _
               "Please correct and try again.", vbOKOnly
        Exit Sub
    End If
 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
 
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        'find last row of data in colA
lastrow = Columns(1).Find("*", searchdirection:=xlPrevious).Row

'copy range and paste 5 rows below lastrow
LoopHere:
    RowCount = Range("A65536").End(xlUp).Row
    For cr = 9 To RowCount
        If Cells(cr, "A").Value = Cells(cr + 1, "A").Value Then
            cr = cr + 2
            'Insert new row
            Rows(cr & ":" & cr).Insert Shift:=xlDown
            Rows(cr - 1 & ":" & cr - 1).Copy Range("A" & cr)
            'SUM values
            Cells(cr, "G").Value = Cells(cr - 2, "G").Value + Cells(cr - 1, "G").Value
            Cells(cr, "I").Value = Cells(cr - 2, "I").Value + Cells(cr - 1, "I").Value
            Cells(cr, "K").Value = Cells(cr - 2, "K").Value + Cells(cr - 1, "K").Value
            Cells(cr, "M").Value = Cells(cr - 2, "M").Value + Cells(cr - 1, "M").Value
            Cells(cr, "O").Value = Cells(cr - 2, "O").Value + Cells(cr - 1, "O").Value
            Cells(cr, "Q").Value = Cells(cr - 2, "Q").Value + Cells(cr - 1, "Q").Value
            Cells(cr, "S").Value = Cells(cr - 2, "S").Value + Cells(cr - 1, "S").Value
            Rows(cr - 2 & ":" & cr - 1).EntireRow.Delete
            GoTo LoopHere
        End If
    Next cr
    Range("I1:M7").Copy Destination:=Cells(lastrow + 7, "A")
    ActiveWindow.Zoom = 70
    ActiveWindow.Zoom = 55
    Range("I1:M7").Select
    Selection.ClearContents
    Columns("F:W").Select
    Selection.ColumnWidth = 8.71
    Columns("AB:AB").Select
    Columns("A:B").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("Q:W").EntireColumn.AutoFit
    Range("A1:W49").Select
    Range("W49").Activate
    ActiveSheet.PageSetup.PrintArea = "$A$1:$AA$49"
     ActiveSheet.PageSetup.CenterFooterPicture.Filename = _
        "Y:QuotingArchiveQuote TemplatesCompanyLogo_Large.jpg"
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
    ActiveSheet.PageSetup.PrintArea = "$A$1:$AA$49"
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = ""
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = "&G"
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.2)
        .RightMargin = Application.InchesToPoints(0.2)
        .TopMargin = Application.InchesToPoints(0.5)
        .BottomMargin = Application.InchesToPoints(1.82)
        .HeaderMargin = Application.InchesToPoints(0.2)
        .FooterMargin = Application.InchesToPoints(0.2)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .PrintQuality = 600
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperLetter
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
        .PrintErrors = xlPrintErrorsDisplayed
    End With
    ActiveWindow.SelectedSheets.PrintPreview
    ActiveWorkbook.Save

        Application.CutCopyMode = False
End With
    
    ActiveWorkbook.SaveAs NewFileName

    ActiveWorkbook.Close SaveChanges:=False
    
    SendTheEmail (NewFileName)

End Sub
Sub SendTheEmail(NewFileName As String)
' creates and sends a new e-mail message with Outlook
Dim OLF As Outlook.MAPIFolder, olMailItem As Outlook.MailItem
Dim ToContact As Outlook.Recipient
    Set OLF = GetObject("", "Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
    Set olMailItem = OLF.Items.Add ' creates a new e-mail message
    With olMailItem
        
    Dim theSubject
    Dim theFileName
    Dim emailTo
    Dim emailCC
    
    theSubject = Worksheets("Quote").Range("n1").Value
    
'    theFileName = ActiveWorkbook.Path & "RFQ " & _
'            Worksheets("Quote").Range("b1").Value & " " & _
'            Worksheets("Quote").Range("n3").Value & " " & _
'            Format(Date, "mmddyy") & " " & Format(Date, "hhmmss")
            
    emailTo = Worksheets("Quote").Range("e6").Value
    
    emailCC = Worksheets("Quote").Range("g6").Value
            
                    .Subject = theSubject ' message subject
        Set ToContact = .Recipients.Add(emailTo) ' add a recipient
        Set ToContact = .Recipients.Add(emailCC) ' add a recipient
        ToContact.Type = olCC ' set latest recipient as CC
        
        ' the message text with a line break
        .Attachments.Add NewFileName, olByValue, , "Attachment" ' insert attachment

        .Display ' shows the message on the screen
        ' .Send ' sends the e-mail message (puts it in the Outbox)
        
    End With
    Set ToContact = Nothing
    Set olMailItem = Nothing
    Set OLF = Nothing
    
End Sub


Function GetBoiler(ByVal sFile As String) As String
'**** Kusleika
    Dim fso As Object
    Dim ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Hi

Enter the following macro:-

Option Explicit
'****************' Main Function *'****************
Function SpellNumber(ByVal MyNumber, Optional IncludePence As Boolean = True)
Dim Pounds, Pence, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion " ' String representation of amount
MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none
DecimalPlace = InStr(MyNumber, ".")
'Convert Pence and set MyNumber to Pound amount
If DecimalPlace > 0 Then
Pence = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp "" Then Pounds = Temp & Place(Count) & Pounds
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Pounds
Case ""
Pounds = "No Pounds"
Case "One"
Pounds = "One Pounds"
Case Else
Pounds = Pounds & " Pounds"
End Select

If IncludePence = False Then
Pence = ""
Else
Select Case Pence
Case ""
Pence = " and No Pence"
Case "One"
Pence = " and One Pence"
Case Else
Pence = " and " & Pence & " Pence"
End Select
End If

SpellNumber = Pounds & Pence
End Function

Monty wrote:
>
> I have input the following formula in order to convert numbers into words.
> the problem is i am working form three work sheets and the formula works
> fine for the first two however in the last worksheet i do not want to
> transfer pence over, how can i get round this if a need pence in the first
> and second sheet but not on the third. see below for macro.
>
> Sub bb()
>
> End Sub
> Option Explicit
>
> '****************' Main Function *'****************
> Function SpellNumber(ByVal MyNumber)
> Dim Pounds, Pence, Temp
> Dim DecimalPlace, Count
> ReDim Place(9) As String
> Place(2) = " Thousand "
> Place(3) = " Million "
> Place(4) = " Billion "
> Place(5) = " Trillion " ' String representation of amount
> MyNumber = Trim(Str(MyNumber)) ' Position of decimal place 0 if none
> DecimalPlace = InStr(MyNumber, ".")
> 'Convert Pence and set MyNumber to Pound amount
> If DecimalPlace > 0 Then
> Pence = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & "00", 2))
> MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
> End If
> Count = 1
> Do While MyNumber ""
> Temp = GetHundreds(Right(MyNumber, 3))
> If Temp "" Then Pounds = Temp & Place(Count) & Pounds
> If Len(MyNumber) > 3 Then
> MyNumber = Left(MyNumber, Len(MyNumber) - 3)
> Else
> MyNumber = ""
> End If
> Count = Count + 1
> Loop
> Select Case Pounds
> Case ""
> Pounds = "No Pounds"
> Case "One"
> Pounds = "One Pounds"
> Case Else
> Pounds = Pounds & " Pounds"
> End Select
> Select Case Pence
> Case ""
> Pence = " and No Pence"
> Case "One"
> Pence = " and One Pence"
> Case Else
> Pence = " and " & Pence & " Pence"
> End Select
> SpellNumber = Pounds & Pence
> End Function
> '*******************************************
> ' Converts a number from 100-999 into text *
> '*******************************************
> Function GetHundreds(ByVal MyNumber)
> Dim Result As String
> If Val(MyNumber) = 0 Then Exit Function
> MyNumber = Right("000" & MyNumber, 3) 'Convert the hundreds place
> If Mid(MyNumber, 1, 1) "0" Then
> Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
> End If
> 'Convert the tens and ones place
> If Mid(MyNumber, 2, 1) "0" Then
> Result = Result & GetTens(Mid(MyNumber, 2))
> Else
> Result = Result & GetDigit(Mid(MyNumber, 3))
> End If
> GetHundreds = Result
> End Function
> '*********************************************
> ' Converts a number from 10 to 99 into text. *
> '*********************************************
> Function GetTens(TensText)
> Dim Result As String
> Result = "" 'null out the temporary function value
> If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19
> Select Case Val(TensText)
> Case 10: Result = "Ten"
> Case 11: Result = "Eleven"
> Case 12: Result = "Twelve"
> Case 13: Result = "Thirteen"
> Case 14: Result = "Fourteen"
> Case 15: Result = "Fifteen"
> Case 16: Result = "Sixteen"
> Case 17: Result = "Seventeen"
> Case 18: Result = "Eighteen"
> Case 19: Result = "Nineteen"
> Case Else
> End Select
> Else ' If value between 20-99
> Select Case Val(Left(TensText, 1))
> Case 2: Result = "Twenty "
> Case 3: Result = "Thirty "
> Case 4: Result = "Forty "
> Case 5: Result = "Fifty "
> Case 6: Result = "Sixty "
> Case 7: Result = "Seventy "
> Case 8: Result = "Eighty "
> Case 9: Result = "Ninety "
> Case Else
> End Select
> Result = Result & GetDigit _
> (Right(TensText, 1)) 'Retrieve ones place
> End If
> GetTens = Result
> End Function
> '*******************************************
> ' Converts a number from 1 to 9 into text. *
> '*******************************************
> Function GetDigit(Digit)
> Select Case Val(Digit)
> Case 1: GetDigit = "One"
> Case 2: GetDigit = "Two"
> Case 3: GetDigit = "Three"
> Case 4: GetDigit = "Four"
> Case 5: GetDigit = "Five"
> Case 6: GetDigit = "Six"
> Case 7: GetDigit = "Seven"
> Case 8: GetDigit = "Eight"
> Case 9: GetDigit = "Nine"
> Case Else: GetDigit = ""
> End Select
> End Function

hope this helps you

"Shahid" wrote:

> In MS Excel I need to convert a numeric value into tex, i.e. 1250="one
> thousand two hundred fifty"

Good morning everybody,

I'm running into a tricky issue, or so i think . I have set up a macro which creates a custom chart based on user selection on a form. The macro/vba code works just fine except when the user first open the workbook, and try to lauch it for the first time. In this case, the macro runs but the results are wrong. Then, if you run the exact same macro a second time, the results are now correct !!!

I can't post the whole file here, but here's the bit of code, I think, that is causing issues. I believe this has something to do with a variable not defined the first time you run the code, and in memory afterwards. But I haven't been abble to locate/fix the issue.


	VB:
	
 DrawChart() 
     
    '**** Declarations**** 
    Set rngData = Range("Data_List") 
    Set rngDataSel = Nothing 
    Dim numSelect, i, xref, yref, Prow, intSeries As Integer 
    Dim x, y, size, sizeref As Variant 
    Dim Pname, ProjectCoord, ProjectStatus, TempChartName As String 
     
    '****Count Number of projects selected In listbox**** 
    numSelect = 0 
    For i = 1 To UserForm2.ListBox3.ListCount - 1 
        If UserForm2.ListBox3.Selected(i) = True Then 
            numSelect = numSelect + 1 
        End If 
    Next i 
     
    '****Test If at least one project Is selected And Set references For x, y, And size**** 
    If numSelect > 0 Or UserForm2.ListBox3.Selected(0) = True Then 
        xref = rngData.Find(UserForm2.ComboBox1.Value).Column - 1 
        yref = rngData.Find(UserForm2.ComboBox2.Value).Column - 1 
        If UserForm2.ComboBox3.Value = "Constant" Then 
            sizeref = UserForm2.ComboBox3.Value 
        Else: 
            sizeref = rngData.Find(UserForm2.ComboBox3.Value).Column - 1 
        End If 
        '****Create Chart**** 
        Application.ScreenUpdating = False 
        Charts.Add 
        '****Add a hidden TextBox Containing the sizeref*** 
        ActiveChart.Shapes.AddTextbox(msoTextOrientationHorizontal, 10, 10, 10, 10).Select 
        With Selection 
            .Name = "Size" 
            .Characters.Text = UserForm2.ComboBox3.Value 
            .ShapeRange.Height = 0# 
            .ShapeRange.Width = 0# 
        End With 
        ActiveChart.ChartArea.Select 
        TempChartName = ActiveSheet.Name 
        '****If All Is selected Then copy every projects In listbox To worksheet hidden02 
        Worksheets("hidden02").Range("A2", Worksheets("hidden02").Range("F2").End(xlDown)).Clear 
        intSeries = 0 
        If UserForm2.ListBox3.Selected(0) = True Then 
            For i = 2 To UserForm2.ListBox3.ListCount 
                Pname = UserForm2.ListBox3.List(i - 1) 
                intSeries = intSeries + 1 
                Prow = rngData.Find(Pname).Row - 1 
                'MsgBox Pname & ", " & Prow 
                Worksheets("Hidden02").Cells(intSeries + 1, 1).Value = Pname 'Project name 
                Worksheets("Hidden02").Cells(intSeries + 1, 2).Value = rngData.Cells(Prow, 1) 'coordination 
                Worksheets("Hidden02").Cells(intSeries + 1, 3).Value = rngData.Cells(Prow, 4) 'Status 
                Worksheets("Hidden02").Cells(intSeries + 1, 4).Value = rngData.Cells(Prow, xref).Value 'x 
                Worksheets("Hidden02").Cells(intSeries + 1, 5).Value = rngData.Cells(Prow, yref).Value 'y 
                If sizeref = "Constant" Then 
                    ActiveChart.ChartGroups(1).BubbleScale = 25 'define here the size of the bubbles 
                    Worksheets("Hidden02").Cells(intSeries + 1, 6).Value = "10" 
                Else: 
                    Worksheets("Hidden02").Cells(intSeries + 1, 6).Value = rngData.Cells(Prow, sizeref).Value 'size 
                End If 
            Next i 
        Else: 
            '****Copy selected projects, And selected variables To temp worksheet 
            For i = 1 To UserForm2.ListBox3.ListCount 
                If UserForm2.ListBox3.Selected(i - 1) = True Then 
                    Pname = UserForm2.ListBox3.List(i - 1) 
                    intSeries = intSeries + 1 
                    Prow = rngData.Find(Pname).Row - 1 
                    Worksheets("Hidden02").Cells(intSeries + 1, 1).Value = Pname 'Project name 
                    Worksheets("Hidden02").Cells(intSeries + 1, 2).Value = rngData.Cells(Prow, 1) 'coordination 
                    Worksheets("Hidden02").Cells(intSeries + 1, 3).Value = rngData.Cells(Prow, 4) 'Status 
                    Worksheets("Hidden02").Cells(intSeries + 1, 4).Value = rngData.Cells(Prow, xref).Value 'x 
                    Worksheets("Hidden02").Cells(intSeries + 1, 5).Value = rngData.Cells(Prow, yref).Value 'y 
                    If sizeref = "Constant" Then 
                        ActiveChart.ChartGroups(1).BubbleScale = 25 'define here the size of the bubbles 
                        Worksheets("Hidden02").Cells(intSeries + 1, 6).Value = "10" 
                    Else: 
                        Worksheets("Hidden02").Cells(intSeries + 1, 6).Value = rngData.Cells(Prow, sizeref).Value 'size 
                    End If 
                End If 
            Next i 
        End If 
         
        '****Sort Data In temp worksheet by size To prevent points overlap**** 
        Worksheets("hidden02").Activate 
        Range("A2", Worksheets("hidden02").Range("F2").End(xlDown)).Select 
        Selection.Sort Key1:=Range("F2"), Order1:=xlDescending, Header:=xlGuess 
         
        Set rngDataSel = Selection 'list of data sorted In hidden02 
         
        '****Add series To chart given the sorted data**** 
        Charts(TempChartName).Activate 
        For i = 1 To rngDataSel.Rows.Count 
            Pname = rngDataSel(i, 1) 
            ProjectCoord = rngDataSel.Cells(i, 2) 
            ProjectStatus = rngDataSel.Cells(i, 3) 
            x = rngDataSel.Cells(i, 4) 
            y = rngDataSel.Cells(i, 5) 
            size = rngDataSel.Cells(i, 6) 
            On Error Resume Next 
            Call DrawBubble(Pname, ProjectCoord, ProjectStatus, x, y, size) 
        Next i 
         
        '***Set Chart Type And Properties**** 
        ActiveChart.ChartType = xlBubble 
        XAxisLabel = rngData.Cells(1, xref).Value 
        YAxisLabel = rngData.Cells(1, yref).Value 
        SizeLabel = rngData.Cells(1, sizeref).Value 
        Call ChartProperties(XAxisLabel, YAxisLabel, SizeLabel) 
        ActiveChart.ChartArea.Select 
         
        '***Ask User To enter a name For the chart created**** 
        UserForm1.Show 
        Application.ScreenUpdating = True 
    Else: MsgBox "Please select at least one project" 
    End If 
     
End Sub 
 
Sub DrawBubble(Pname, ProjectCoord, ProjectStatus, x, y, size) 
     
    '****Declarations**** 
    Set rngcolor = Range("ColorCoord_List") 
    Set rngcolorstatus = Range("ColorStatus_List") 
     
     
    '***Add serie To the Chart**** 
    With ActiveChart.SeriesCollection.NewSeries 
        '****Set Name**** 
        .Name = Pname 
        '****Set X value**** 
        On Error Resume Next 
        If IsError(x) = True Or x = "" Then 
            If UserForm2.CheckBox1.Value = True Then 
                MsgBox " X Value error with " & Pname 
            End If 
        Else: 
            .XValues = x 
        End If 
        '****Set Y value**** 
        On Error Resume Next 
        If IsError(y) = True Or y = "" Then 
            If UserForm2.CheckBox1.Value = True Then 
                MsgBox " Y Value error with " & Pname 
            End If 
        Else: 
            .Values = y 
        End If 
        '****Set Size**** 
        On Error Resume Next 
        If IsError(size) = True Or size = "" Then 
            .BubbleSizes = "={0}" 
        Else: 
            .BubbleSizes = "={" & size & "}" 
        End If 
        '****Set BorderColor And Interior Color according To Status And Coordination**** 
        .Border.Weight = xlMedium 
        .Border.LineStyle = xlContinuous 
        .Interior.Pattern = xlSolid 
        If Not rngcolorstatus.Find(ProjectStatus) Is Nothing Then 
            .Border.Color = rngcolorstatus(rngcolorstatus.Find(ProjectStatus).Row - 5, 2).Interior.Color 
        Else: .Border.Color = rngcolorstatus(rngcolorstatus.Find("Unknown").Row - 5, 2).Interior.Color 
        End If 
        If Not rngcolor.Find(ProjectCoord) Is Nothing Then 
            .Interior.Color = rngcolor(rngcolor.Find(ProjectCoord).Row - 5, 2).Interior.Color 
        Else: .Interior.Color = rngcolor(rngcolor.Find("Unknown").Row - 5, 2).Interior.Color 
        End If 
    End With 
End Sub 

If you like these VB formatting tags please consider sponsoring the author in support of injured Royal Marines
Sorry, I understand the code might be overwhelming but since I haven't been able to identify where the error occurs, I couldn't simplify it too much.

The other parts of the code not posted here dont seem to be related.

Thanks in advance for your tremendous help.

Best regards,

I have written a Macro to record Registration information for up to 2,000
people registered at a Lions Convention.

I use a userform to enter the information for each Registration. Based on
the type of Registration, I would like to be able to highlight the LastRow
in an appropriate color. Since the database is dynamic, I am having
difficulty selecting the Last row (Uses A(lastRow):l(Lastrow)). This is the
code I have written (albeit not well) so far. It will highlight the very
first cell in the LastRow but will not select entire row.

If anyone can steer me straight I would appreciate it.

My Code
=================================
Private Sub CommandButton1_Click()

Dim LastRow As Object
Dim Response As String
Dim Ts As Integer, Lu As Integer, Sheets2 As Worksheet

' Application.Visible = False
Set LastRow = Sheet1.Range("a65536").End(xlUp)

Ts = 0
Lu = 0
If Sheets.Count <> 1 Then Sheets(1).Activate
LastRow.Activate

LastRow.Offset(1, 0).Value = txtName.Text
LastRow.Offset(1, 1).Value = txtClub.Text
LastRow.Offset(1, 2).Value = cmbDist.Text
LastRow.Offset(1, 3).Value = 1 ' txtPersons.Text

On Error Resume Next

If CheckBox1 = True Or CheckBox2 = True Then
LastRow.Offset(1, 4).Value = 10
Else
LastRow.Offset(1, 4).Value = 20
End If

If CheckBox1 = True Then
MsgBox ("Sun Only - No Room deposit required!")
LastRow.Offset(1, 5).Value = ""
End If

If CheckBox2 = True Then
MsgBox ("This is a Leo - Registration is only One Half!")

Else
LastRow.Offset(1, 5).Value = txtRoomDep.Text
End If

LastRow.Offset(1, 8).Value = txtLunch.Text
Lu = LastRow.Offset(1, 8).Value * 25
Ts = Ts + Lu
LastRow.Offset(1, 9).Value = txtTheatre.Text
Lu = LastRow.Offset(1, 9).Value * 30
Ts = Ts + Lu
LastRow.Offset(1, 10).Value = txtBanquet.Text
Lu = LastRow.Offset(1, 10).Value * 55
Ts = Ts + Lu
LastRow.Offset(1, 11).Value = txtDance.Text
Lu = LastRow.Offset(1, 11).Value * 5
Ts = Ts + Lu
' LastRow.Offset(1, 12).Value = txtPDG.Text
' Lu = LastRow.Offset(1, 12).Value * 20
' Ts = Ts + Lu
LastRow.Offset(1, 6).Value = Ts

If OptionButton1 = True Then
LastRow.Offset(1, 14).Value = "M" ' Using Master Card
End If
If OptionButton2 = True Then
LastRow.Offset(1, 14).Value = "V" ' Using Visa
End If
Set LastRow = Sheet1.Range("a65536").End(xlUp)
LastRow.Activate

MsgBox ("The Last row booked is " & LastRow())
' Sheets(1).Activate
Range.Cells("A(LastRow):L(LastRow)").Select
With Selection.Font
.Name = "Arial"
.FontStyle = "Regular"
.Size = 10
' .Strikethrough = False
' .Superscript = False
' .Subscript = False
' .OutlineFont = False
' .Shadow = False
' .Underline = xlUnderlineStyleNone
.ColorIndex = 10
End With

MsgBox "One record written to Sheet1"

=====================================================

DennisB

I'm trying to create a macro which does this:

Allows me to choose a few workbooks (usually about 4-5 but could be anywhere from 2-15) from a server and consolidate them into one workbook. Each workbook needs to be a seperate sheet.
Each workbook consists of 2 sheets however only the 1st sheet will be needed to transfer.
At the end I would like to be able to create a summary sheet. (all of the previous sheets onto one summary sheet at the end)

Other notes:
These files all have different names so i have to be able to choose which files i want consolidated.
I'm running excel 2010.
I would like to be able to keep the same formatting as the sheet im transfering.

So far... I was able to find this macro. The problem with this is that it puts all workbooks selected on one sheet, and for some reason it wraps the text.

Private Declare Function SetCurrentDirectoryA Lib _
     "kernel32" (ByVal lpPathName As String) As Long

Sub ChDirNet(szPath As String)
     SetCurrentDirectoryA szPath
 End Sub

Sub Combine_Workbooks_Select_Files()
     Dim MyPath As String
     Dim SourceRcount As Long, Fnum As Long
     Dim mybook As Workbook, BaseWks As Worksheet
     Dim sourceRange As Range, destrange As Range
     Dim rnum As Long, CalcMode As Long
     Dim SaveDriveDir As String
     Dim FName As Variant
     
     

    With Application
         CalcMode = .Calculation
         .Calculation = xlCalculationManual
         .ScreenUpdating = False
         .EnableEvents = False
     End With

    SaveDriveDir = CurDir
     ChDirNet "C:"

    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                                         MultiSelect:=True)
     If IsArray(FName) Then
         Set BaseWks = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
         rnum = 1
         For Fnum = LBound(FName) To UBound(FName)
             Set mybook = Nothing
             On Error Resume Next
             Set mybook = Workbooks.Open(FName(Fnum))
             On Error GoTo 0
             If Not mybook Is Nothing Then
                 On Error Resume Next
                 With mybook.Worksheets(1)
                     Set sourceRange = .Range("A10:F40")
                 End With
                 If Err.Number > 0 Then
                     Err.Clear
                     Set sourceRange = Nothing
                 Else
         If sourceRange.Columns.Count >= BaseWks.Columns.Count Then
                         Set sourceRange = Nothing
                     End If
                 End If
                 On Error GoTo 0

                If Not sourceRange Is Nothing Then

                    SourceRcount = sourceRange.Rows.Count

                    If rnum + SourceRcount >= BaseWks.Rows.Count Then
                         MsgBox "Not enough rows in the sheet. "
                         BaseWks.Columns.AutoFit
                         mybook.Close savechanges:=False
                         GoTo ExitTheSub
                     Else
                         Set destrange = BaseWks.Range("A" & rnum)
                         With sourceRange
                             Set destrange = destrange. _
                                             Resize(.Rows.Count, .Columns.Count)
                         End With
                         destrange.Value = sourceRange.Value

                        rnum = rnum + SourceRcount
                     End If
                 End If
                 mybook.Close savechanges:=False
             End If
         Next Fnum
         BaseWks.Columns.AutoFit
     End If
ExitTheSub:
    With Application
         .ScreenUpdating = True
         .EnableEvents = True
         .Calculation = CalcMode
     End With
     ChDirNet SaveDriveDir
 End Sub
Any help would be greatly appreciated.

Thanks.

I am currently trying to get three subroutines to run harmoniously with each other and for some reason or another (my VBA noobness most likely) I can't seem to figure out the call statements correctly, nor am I sure of the best way to pass the selected range and have them run off this range. I've arrived at this point of trying to integrate the pieces of this project together (they successfully and do their job alone) via a lot of help from OnErrorGoto0 within this thread: http://www.excelforum.com/excel-prog...59#post2700959

The following is the code I'm trying to get to run together, I have them all within a single module and attempt to call the second from the first. The second purely just sends the range to the third. When developing them I would test the second and the third together and the first alone, and both ran successfully. Although the second and the third requiring a few files to be stored locally on your machine for the tag cloud to actually be generated within the web browser.

Sub MakeTable3()

    Dim CloudData As Range
    Dim Pt As PivotTable
    Dim strField As String
    Dim oDic As Object
    Dim varData
    Dim varItems
    Dim varKeys
    Dim n As Long
    Dim wksTable As Worksheet
    Dim lngTop5Count As Long

    Const cstrSHEET_NAME As String = "Incident Summary"
    On Error Resume Next

    'Asks user to specify which column of data they wish to summarize
    Set CloudData = Application.InputBox("Please select a range with the incident information you wish to
summarize.", _
                                         "Specify Incident Information", Selection.Address, , , , , 8)
    On Error GoTo err_handle
    Application.ScreenUpdating = False

    If Not CloudData Is Nothing Then
        Set oDic = CreateObject("Scripting.Dictionary")
        strField = Cells(1, CloudData.Column).Value
        With CloudData
            If .Row = 1 Then
                varData = .Resize(.Rows.Count - 1).Offset(1).Value
            Else
                varData = .Value
            End If
        End With
        For n = 1 To UBound(varData, 1)
            If Len(varData(n, 1)) > 0 Then
                oDic(CStr(varData(n, 1))) = Val(oDic(CStr(varData(n, 1)))) + 1
            End If
        Next n

        If oDic.Count > 0 Then

            On Error Resume Next
            Application.DisplayAlerts = False
            Sheets(cstrSHEET_NAME).Delete
            Application.DisplayAlerts = True
            On Error GoTo err_handle

            Set wksTable = Sheets.Add
            With wksTable
                .Name = cstrSHEET_NAME
                .Range("A1:B1").Value = Array(strField, "Total")
                varItems = oDic.Items
                varKeys = oDic.Keys
                If oDic.Count > 5 Then
                   lngTop5Count = Application.Large(varItems, 5)
                Else
                   lngTop5Count = 0
                End If
                For n = LBound(varItems) To UBound(varItems)
                    If varItems(n) >= lngTop5Count Then
                        With .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
                            .Value = varKeys(n)
                            .Offset(, 1).Value = varItems(n)
                        End With
                    End If
                Next n
                'Sorts frequency table descending.
                With .Range("A1").CurrentRegion
                    .Sort .Cells(1, 2), xlDescending
                End With
            End With

        End If
    End If
    
    ActiveSheet.OLEObjects.Add(ClassType:="Shell.Explorer.2", Link:=False, _
        DisplayAsIcon:=False, Left:=383.25, Top:=45, Width:=324.75, Height:= _
        225).Select
    ActiveSheet.Shapes("WebBrowser1").ScaleWidth 1.480369515, msoFalse, _
        msoScaleFromTopLeft
    ActiveSheet.Shapes("WebBrowser1").ScaleHeight 1.3966666667, msoFalse, _
        msoScaleFromTopLeft
leave:
    Application.ScreenUpdating = True
    Exit Sub
err_handle:
    MsgBox Err.Description
    Resume leave
    
Call test

End Sub

Public Sub test()
'this subroutine produces a tag cloud and places it within the Web Browser contained
'on "Incident Summary" (cstrSHEET_NAME) worksheet. It does this by calling WordCloud
'subroutine which creates the tag cloud using a jscript file stored locally.

 WordCloud Selection
 
End Sub


Sub WordCloud(rngInput As Range)
Dim wbString As String
Dim myFile As String
Dim rngVar As Variant
Dim fnum As Integer
Dim i As Integer

rngVar = Application.Transpose(rngInput.Value)


wbString = "<html>" & vbCr
wbString = wbString & "  <head>"

'wbString = wbString & "    <link rel=""stylesheet"" type=""text/css""
href=""http://visapi-gadgets.googlecode.com/svn/trunk/wordcloud/wc.css""></script>" &
vbCr
'wbString = wbString & "    <script type=""text/javascript""
src=""http://visapi-gadgets.googlecode.com/svn/trunk/wordcloud/wc.js""></script>" &
vbCr
'wbString = wbString & "    <script type=""text/javascript""
src=""http://www.google.com/jsapi""></script>" & vbCr

wbString = wbString & "    <link rel=""stylesheet"" type=""text/css""
href=""wc.css""></script>" & vbCr
wbString = wbString & "    <script type=""text/javascript""
src=""wcbackup3.js""></script>" & vbCr
wbString = wbString & "    <script type=""text/javascript""
src=""jsapi""></script>" & vbCr

wbString = wbString & "  </head>" & vbCr
wbString = wbString & "  <body>" & vbCr
wbString = wbString & "    <div id=""wcdiv""></div>" & vbCr
wbString = wbString & "    <script type=""text/javascript"">" & vbCr
wbString = wbString & "      google.load('visualization', '1');" & vbCr
wbString = wbString & "      google.setOnLoadCallback(draw);" & vbCr
wbString = wbString & "      function draw() {" & vbCr
wbString = wbString & "        var data = new google.visualization.DataTable();" & vbCr
wbString = wbString & "        data.addColumn('string', 'Text1');" & vbCr
wbString = wbString & "        data.addRows(" & UBound(rngVar) & ");" & vbCr

For i = 1 To UBound(rngVar)
    wbString = wbString & "        data.setCell(" & i - 1 & ", 0,'" & rngVar(i) &
"');" & vbCr
Next i

wbString = wbString & "        var outputDiv = document.getElementById('wcdiv');" & vbCr
wbString = wbString & "        var wc = new WordCloud(outputDiv);" & vbCr
wbString = wbString & "        wc.draw(data, null);" & vbCr
wbString = wbString & "      }" & vbCr
wbString = wbString & "    </script>" & vbCr
wbString = wbString & "  </body>" & vbCr
wbString = wbString & "</html>"


myFile = ThisWorkbook.Path & "WordCloud.htm"
fnum = FreeFile()
Open myFile For Output As fnum
Print #fnum, wbString
Close #fnum


With Sheets("Incident Summary").WebBrowser1
    .Silent = True
    .Navigate (myFile)
    Do
        DoEvents
    Loop Until .ReadyState = READYSTATE_COMPLETE
    .Document.body.Scroll = "no"
End With

MsgBox "Macro Finished."

End Sub
I can tell the last subroutine is not being run as I never see the "Macro Finished." So it's more than it just not being passed the range, I believe its not being ran at all. One thing I would like to change is for the first subroutine MakeTable3 to run purely off of whatever range is selected (similar to how the other two subroutines have been written to just run off the selected range)...I'd like to the user to be able to highlight a range and just press play and have the summary sheet appear. Thanks in advance to anyone who has any advice for how I can accomplish this! This forum rocks!

Hello,

I have a sub that copies rows from one worksheet and pastes them into the first available empty cell in another worksheet. The sub breaks after pasting 1M+ iterations of a given row into the destination worksheet. I do not want the sub to paste 1M+ iterations of the row. I want it to paste the row once.

Stepping through the code and running the sub produce different, seemingly random breakpoints: e.g., Excel pastes 1M+ iterations of record 18 on one go, and 1M+ iterations of record 23 next time around. Anyone have thoughts? Have pasted code below.

Thanks,

Zack

Sub cleanreps()

Dim ws As Worksheet
Dim fullstr As String, strname As String
Dim i As Long, k As Long

Application.ScreenUpdating = False
Application.EnableCancelKey = xlDisabled

For Each ws In ActiveWorkbook.Worksheets
    Select Case ws.Name
        Case "Streams", "A1feed", "T1E", "UniqueHeadlineFeed"
        Case Else
            ws.Activate
            ws.Cells.ClearContents
    End Select
    Next ws

Worksheets("Streams").Activate
Range("A1").Activate

For i = 1 To (ActiveSheet.UsedRange.Rows.Count - 1)
    fullstr = Range("a1").Offset(i, 5).Value
    If Left(fullstr, 3) = "By " Then
            strname = Application.WorksheetFunction.clean(Mid(fullstr, 4, (((CharPos(fullstr, Chr(32), 3) - 1) - 3))))
        Else
            strname = Application.WorksheetFunction.clean(Left(fullstr, (CharPos(fullstr, Chr(32), 2) - 1)))
        End If
    Rows(i + 1).EntireRow.Copy
    Worksheets(strname).Activate
    k = 0
        Do While ActiveSheet.Range("a1").Offset(k, 0).Value <> ""
            k = k + 1
        Loop
    ActiveSheet.Range("a1").Offset(k, 0).Activate
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Sheets("Streams").Activate
    Range("a1").Activate
Next i

Application.ScreenUpdating = True
    
End Sub


Function CharPos(SearchString As String, Char As String, Instance As Long)
     'Function purpose:  To return the position of the (first character of the )
     'nth occurance of a specific character set in a range
    Dim x As Long, n As Long
     'Loop through each letter in the search string
    For x = 1 To Len(SearchString)
         'Increment the number of characters search through
        CharPos = CharPos + 1
         
         'check if the next character(s) match the text being search for
         'and increase n if so (to count how many matches have been found
        If Mid(SearchString, x, Len(Char)) = Char Then n = n + 1
         
         'Exit loop if instance matches number found
        If n = Instance Then Exit Function
    Next x
         
End Function


Hi All,

I have a module that imports data from a text file (120000 rows), filters and removes some unneeded (85000)rows and then puts the data in a designated workbook.
Problem: when filtering by some criteria it for some reason removes a row off the final file for each criteria. I have a total of 23 filtering criteria. I have attached a file for exemplification. You can run the module and import the file, it will be without first 23 rows, even if non of the deleted rows contained the filter criteria.
example.txt
Sub ImportData()
' First it imports the file
    Dim ResultStr As String
    Dim FileName As String
    Dim FileNum As Integer
    Dim Counter As Double
     'Ask User for File's  Name
    FileName = Application.GetOpenFilename
     'Check for no entry
    If FileName = "" Then End
     'Get Next Available File Handle Number
    FileNum = FreeFile()
     'Open Text File For Input
    Open FileName For Input As #FileNum
     'Turn Screen Updating Off
    Application.ScreenUpdating = False
     'Create A New WorkBook With One  Worksheet In It
    Workbooks.Add Template:=xlWorksheet
     'Set The Counter to 1
    Counter = 1
     ' Loop Until the End Of File Is Reached
    Do While Seek(FileNum) <= LOF(FileNum)
         'Display  Importing Row Number On Status Bar
        Application.StatusBar = "Importing Row " & Counter & " of text file " _
        & FileName
         'Store One Line Of Text From File To  Variable
        Line Input #FileNum, ResultStr
         'Store Variable Data Into Active Cell
        If Left(ResultStr, 1) = "=" Then
            ActiveCell.Value = "'" & ResultStr
        Else
            ActiveCell.Value = ResultStr
        End If
        If ActiveCell.Row = 65536 Then
             'If On The Last Row Then Add A New Sheet
             ActiveWorkbook.Sheets.Add
        Else
             'If Not The Last Row Then Go One Cell Down
            ActiveCell.Offset(1, 0).Select
        End If
         'Increment the Counter By 1
        Counter = Counter + 1
         'Start Again At Top Of 'Do While' Statement
    Loop
     'Close The Open Text File
    Close
     'Remove Message From Status Bar
    Application.StatusBar = False
    
Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2)), TrailingMinusNumbers:= _
        True

' Then the filtering follows
Dim rng As Range
Dim calcmode As Long
Dim myArr As Variant
Dim I As Long

    With Application
        calcmode = .Calculation
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
    End With

    'The values for the filter (the 23 criteria, it deletes a row for each even if it shouldn't)
    myArr = Array("01*", "02*", "04*", "0999*", "10*", "110*",
"111*", "112*", "113*", "114*", "115*", "12*", "13*",
"14*", "15*", "16*", "17*", "18*", "19*", "5*",
"6*", "8*", "9*")

    For I = LBound(myArr) To UBound(myArr)

        'Sheet with the data, you can also use Sheets("MySheet")
        With ActiveSheet

            'Firstly, remove the AutoFilter
            .AutoFilterMode = False

            'Apply the filter
            .Range("A1:A" & .Rows.Count).AutoFilter Field:=1, Criteria1:=myArr(I)

            Set rng = Nothing
            With .AutoFilter.Range
                On Error Resume Next
                Set rng = .Offset(0, 0).Resize(.Rows.Count - 1, 1) _
                          .SpecialCells(xlCellTypeVisible)
                On Error GoTo 0
                If Not rng Is Nothing Then rng.EntireRow.Delete
            End With

            'Remove the AutoFilter
            .AutoFilterMode = False
        End With

    Next I

    With Application
        
        .Calculation = calcmode
    End With
' Then some copying of final data follows
    Range("A:A,C:C").Select
    Range("C1").Activate
    Selection.Copy
    Windows("Audit Tool.xls").Activate
    Sheets("Sheet1").Activate
    Range("A1").Select
    ActiveSheet.Paste
    
        
    Dim Lastrow As Long
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    Sheets("Sheet2").Columns("A:B").ClearContents
    Range("A1:A" & Lastrow).Copy Sheets("Sheet2").Range("A3")
    Range("B1:B" & Lastrow).Copy Sheets("Sheet2").Range("B3")
    Sheets("Sheet2").Activate
    Range("A1").Select
    
End Sub
Please look into the code and help me figure out what is wrong with it.
Any ideas appreciated.

I am using the following code in the module, which worked initially but not
working now. Need help to convert numbers to text

Option Explicit
'Main Function
Function SpellNumber(ByVal MyNumber)
Dim Dollars, Cents, Temp
Dim DecimalPlace, Count
ReDim Place(9) As String
Place(2) = " Thousand "
Place(3) = " Million "
Place(4) = " Billion "
Place(5) = " Trillion "
' String representation of amount.
MyNumber = Trim(Str(MyNumber))
' Position of decimal place 0 if none.
DecimalPlace = InStr(MyNumber, ".")
' Convert cents and set MyNumber to dollar amount.
If DecimalPlace > 0 Then
Cents = GetTens(Left(Mid(MyNumber, DecimalPlace + 1) & _
"00", 2))
MyNumber = Trim(Left(MyNumber, DecimalPlace - 1))
End If
Count = 1
Do While MyNumber <> ""
Temp = GetHundreds(Right(MyNumber, 3))
If Temp <> "" Then Dollars = Temp & Place(Count) & Dollars
If Len(MyNumber) > 3 Then
MyNumber = Left(MyNumber, Len(MyNumber) - 3)
Else
MyNumber = ""
End If
Count = Count + 1
Loop
Select Case Dollars
Case ""
Dollars = "No Dollars"
Case "One"
Dollars = "One Dollar"
Case Else
Dollars = Dollars & " Dollars"
End Select
Select Case Cents
Case ""
Cents = " and No Cents"
Case "One"
Cents = " and One Cent"
Case Else
Cents = " and " & Cents & " Cents"
End Select
SpellNumber = Dollars & Cents
End Function

' Converts a number from 100-999 into text
Function GetHundreds(ByVal MyNumber)
Dim Result As String
If Val(MyNumber) = 0 Then Exit Function
MyNumber = Right("000" & MyNumber, 3)
' Convert the hundreds place.
If Mid(MyNumber, 1, 1) <> "0" Then
Result = GetDigit(Mid(MyNumber, 1, 1)) & " Hundred "
End If
' Convert the tens and ones place.
If Mid(MyNumber, 2, 1) <> "0" Then
Result = Result & GetTens(Mid(MyNumber, 2))
Else
Result = Result & GetDigit(Mid(MyNumber, 3))
End If
GetHundreds = Result
End Function

' Converts a number from 10 to 99 into text.
Function GetTens(TensText)
Dim Result As String
Result = "" ' Null out the temporary function value.
If Val(Left(TensText, 1)) = 1 Then ' If value between 10-19...
Select Case Val(TensText)
Case 10: Result = "Ten"
Case 11: Result = "Eleven"
Case 12: Result = "Twelve"
Case 13: Result = "Thirteen"
Case 14: Result = "Fourteen"
Case 15: Result = "Fifteen"
Case 16: Result = "Sixteen"
Case 17: Result = "Seventeen"
Case 18: Result = "Eighteen"
Case 19: Result = "Nineteen"
Case Else
End Select
Else ' If value between 20-99...
Select Case Val(Left(TensText, 1))
Case 2: Result = "Twenty "
Case 3: Result = "Thirty "
Case 4: Result = "Forty "
Case 5: Result = "Fifty "
Case 6: Result = "Sixty "
Case 7: Result = "Seventy "
Case 8: Result = "Eighty "
Case 9: Result = "Ninety "
Case Else
End Select
Result = Result & GetDigit _
(Right(TensText, 1)) ' Retrieve ones place.
End If
GetTens = Result
End Function

' Converts a number from 1 to 9 into text.
Function GetDigit(Digit)
Select Case Val(Digit)
Case 1: GetDigit = "One"
Case 2: GetDigit = "Two"
Case 3: GetDigit = "Three"
Case 4: GetDigit = "Four"
Case 5: GetDigit = "Five"
Case 6: GetDigit = "Six"
Case 7: GetDigit = "Seven"
Case 8: GetDigit = "Eight"
Case 9: GetDigit = "Nine"
Case Else: GetDigit = ""
End Select
End Function

HTML Code: 
Option Explicit

Sub GenResult()

    Const sEventType = "GENSET IN OPERATION"
    Const sEventTime = "Event time:"
    Const sClearTime = "Clear time:"
    Const sSite = "MO                RSITE            CLASS"
    
    Dim rDest As Range
    Dim rSource As Range
    Dim rEventType As Range
    Dim rEventTime As Range
    Dim rNode As Range
    Dim sFirstEventTypeAddress As String
    Dim cEventTypeRange As Collection
    
    'Set source range
    With Worksheets("Input")
        Set rSource = .Range(.Range("A1"), .Cells(Rows.Count, "A").End(xlUp))
    End With
    
    'Set destination range
    With Worksheets("Results")
        Set rDest = .Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)
    End With
    
    'Initialize collection
    Set cEventTypeRange = New Collection
    
    ' Set rEventtype at end of file
    Set rEventType = rSource.Cells(rSource.Cells.Count)
    'Find first event type equal to GENSET IN OPERATION
    Set rEventType = rSource.Find( _
        what:=sEventType, _
        after:=rEventType, _
        LookIn:=xlValues, _
        lookat:=xlPart, _
        searchorder:=xlByColumns, _
        searchdirection:=xlNext, _
        MatchCase:=True _
        )
    'Exit if not found
    If rEventType Is Nothing Then
        MsgBox "No item found"
        Exit Sub
    End If
    
    'Save address of first element found
    sFirstEventTypeAddress = rEventType.Address
    
    'Loop thru input sheet to memorize GENSET events position
    Do
        cEventTypeRange.Add rEventType
        Set rEventType = rSource.FindNext(after:=rEventType)
    Loop Until rEventType.Address = sFirstEventTypeAddress
    
    'Loop thru collection to process each event type
    For Each rEventType In cEventTypeRange
        ' Copy column A header from previous row
        rDest.Offset(0, -1).Value = rDest.Offset(-1, -1).Value
    
        ' set event type
        rDest.Value = Trim(rEventType.Text)
        
        'Search up for Event time
        Set rEventTime = rSource.Find( _
            what:=sEventTime, _
            after:=rEventType, _
            searchdirection:=xlPrevious)
        ' Assume string was found
        ' Set event date/time
        rDest.Offset(0, 1).Value = Mid(rEventTime.Text, 35, 10)
        rDest.Offset(0, 2).Value = Mid(rEventTime.Text, 49, 8)
        
        'Search down for Clear time
        Set rEventTime = rSource.Find( _
            what:=sClearTime, _
            after:=rEventType, _
            searchdirection:=xlNext)
        ' Assume string was found
        ' Set clear date/time
        rDest.Offset(0, 3).Value = Mid(rEventTime.Text, 35, 10)
        rDest.Offset(0, 4).Value = Mid(rEventTime.Text, 49, 8)
        
        'Search up for Node header
        Set rNode = rSource.Find( _
            what:=sSite, _
            after:=rEventType, _
            searchdirection:=xlPrevious).Offset(1, 0)
        ' Assume string was found
        ' Set Node name
        rDest.Offset(0, 5).Value = Trim(Mid(rNode.Text, 19, 10))
        

        Set rDest = rDest.Offset(1, 0)      'skip to next line
    Next rEventType
    
End Sub
Hi all , take a look at code above . what it is doing is looking at input in sheet "Input" and extracting information to sheet "Results" ..
since this code is only looking at blocks of input having string "GENSET IN OPERATION" , i want it to look at some other strings of my choice .. like "door open " , "this is gate " .. anything and extract same information to different sheet for each different string ..
along with that in column 'H' starting from 'H2 to downwards' , i want this formula to be copied and computed "F2-D2-C2+E2" , setting format of 'H' as hh:mm:ss
and one last thing is to delete all those entire rows which have blank value in column 'E'
i know this is kinda confusing , but i m dire need of this and looking for help from gurus
Regards

Hello evryone,

I am building an application where in i need some help to develop macros!

I am new to VB macros and I am clueless to how to even proceed with the programming part.
I have tried a lot of forums online and I couldnt get what I want.
I am new to this forum too.

I will be grateful if some one can give me any suggestions on inputs on my requirements.
This is solely for my work related stuff. I am on new job and cannot even say a NO!

I have attached my macro at end of the post and also the sample Excel file which I am trying to work on. I am also attaching the picture file of desired output deck (just to be more clear about the output I need)
Kindly have a look at them.

My Problem:

I have an excel sheet with approx 1200 columns-using Excel 2007 (columns: A to APS).
The headers for the coulmns are specified in the second row. I need a program which can read the
entire file like all the contents(row-wise) and put it in a formatted way to a text file. The formatting should be :
1>Each row in the text file should start with a "+" sign and the values read from the excel should be
formatted and placed in 8 characters long. I do not want the header data here!!

In my data in Excel sheet I also have a challenge of comparing few headers feilds.
To be precise,
ēFields/Columns in the Excel data are fixed set.
ēI have a feild called "drive type". If the drive type is CDD then the data in the row should be read else can be skipped.
ēThe content in the field named Description in the Excel sheet is added as a comment in the text file generated so should start with '.
ēI have some nos in the headers, If the value for that nos is blank in the rows then they should be skipped.
ēThe first occurrence of the data is considered as the entry point. (That should be also mentioned in text file!!)
ēValues are valid if it is x or x.5 (where x is a whole no. Rest all the values which do not equal this are ignored)
ēA count of how many values are obtained is kept for each DID and Date ID and is outputted in the text file.
I need the text file to be generated though excel itself. We can add the button or something!

I am working on customizing the ribbon. If you can also provide me some inputs on that I shall appreciate it. ( I know about XML and Custom UI for making these-through all forums)

I have tried to write a small macro which is reading columns and also saving them in text file. I am attching that macro here:
But defnitely not doing a great job!!

MY macro:

Sub book()
Dim sName As String
Dim rng As Range, cell As Range
sName = ActiveSheet.Name
sName = Application.GetSaveAsFilename( _
InitialFileName:=sName & ".txt", _
FileFilter:="Text Files (*.txt),*.txt")
If sName = "" Then Exit Sub
Open sName For Output As #1
Set rng = Range(Range("A2:NM2"), _
   Cells(Rows.Count, 1).End(xlUp))
For Each cell In rng
 Print #1, cell.Text
 Print #1, cell.Offset(0, 1).Text
 Print #1,
Next
   Close #1
   
End Sub

I look forward and really appreciate your help.
Thanks a lot,
Macromaniac

<<Attachments goes here>>

output_desired.JPG

Data.xlsx

I need to solve a number of non linear equations using VBA (specifically this is for estimation of the equilibrium composition of an gas mixture using Gibbs free energy minimization which will have at least 10 non lin. equations to solve). The problem is that the code I have (from "EXCEL FOR SCIENTISTS & ENGINEERS by E.Joseph Billo) using gaussian jordan elimination/matrix pivoting, it produces a zero pivot & thus an error when the matrix elements are divided by the pivot.

Can anyone suggest how I augment the code to overcome this problem (division by zero pivot term) or has anyone else a better code for non linear equations solver. CODE BELOW

''''''''''''''''''''CODE'''''''''''''''''''''''''''''''
Option Explicit
Option Base 1

Const ConvergenceTolerance = 0.00000001
Const IncermentNumericalDifferentiation = 0.000000001
Const Iterations = 50
Const expon = 2.718281828

Function SimultEqNL(equations, Variables, constants)
' Newton iteration method to find roots of nonlinear simultaneous equations
' Example:
' w^3 + 2w^2 + 3w + 4 = +12.828
' w.x + x.y + y.z = -3.919
' w^2 + 2w.x + x^2 = +1
' w + x + y - z = -3.663
'
' WHERE: constants = [12.828,-3.919,1,-3.663];

'On Error Resume Next

Dim i As Integer, j As Integer, k As Integer, N As Integer
Dim Nlterations As Integer
Dim R As Integer, C As Integer
Dim VarAddr() As String, FormulaString() As String
Dim con() As Double, A() As Double, B() As Double
Dim V() As Double
Dim Y1 As Double, Y2 As Double
Dim tolerance As Double, incr As Double

N = equations.Rows.count
k = Variables.Rows.count

If k = 1 Then k = Variables.Columns.count
If k <> N Then SimultEqNL = CVErr(xlErrRef): Exit Function
' Use the CVErr function to create user-defined errors in user-created procedures.
' For example, if you create a function that accepts several arguments and normally returns a string,
' you can have your function evaluate the input arguments to ensure they are within acceptable range.
' If they are not, it is likely your function will not return what you expect.
' In this event, CVErr allows you to return an error number that tells you what action to take.

ReDim VarAddr(N), FormulaString(N), V(N), con(N)
ReDim A(N, N + 1), B(N, N + 1)

tolerance = ConvergenceTolerance 'Convergence criterion.
incr = IncermentNumericalDifferentiation 'Increment for numerical differentiation.
Nlterations = Iterations

For i = 1 To N
VarAddr(i) = Variables(i).Address
' i.e. VarAddr(1) = $A$11
Next i

' Initial values
For i = 1 To N
con(i) = constants(i).Value
' Put the initial guesses into vector V()
V(i) = Variables(i).Value: If V(i) = 0 Then V(i) = 1
Next i

For j = 1 To Nlterations
' Create N x N matrix of partial derivatives.
For R = 1 To N ' n = equations.Rows.count
For C = 1 To N
' Formulastring is formula in which all but one variable in each equation is replaced by current values.
FormulaString(R) = Application.ConvertFormula(equations(R).Formula, xlA1, xlA1, xlAbsolute)
' xlA1 = Use xlA1 to return an A1-style reference. xlR1C1 = Use xlR1C1 to return an R1C1-style reference
' xlAbsolute = Convert to absolute row and column style

' ConvertFormula method used to convert cell references from A1 reference style to R1C1 reference style
For i = 1 To N
' Debug.Print FormulaString(R)
If i <> C Then FormulaString(R) = Application.Substitute(FormulaString(R), VarAddr(i), V(i))
' Substitutes new_text for old_text in a text string.
' FormulaString(R) = the reference to a cell containing text for which you want to substitute characters.
' Replace the address reference with the actual variable value i.e. $B$5^3 + 2*$B$5^2 + 3*$B$5 + 4-$R$5+3-1^3
' i = C means its on the diagonal of the matrix
Next i
' V() = vector of current variable values
If IsError(Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), V(C) * (1 + incr)))) Then MsgBox "ERROR IS FORMAULA EVALUATION"
If IsError(Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), V(C) * (1 - incr)))) Then MsgBox "ERROR IS FORMAULA EVALUATION"

' Y2 = Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), (V(C) + incr)))
' ' value of the equation at the current variable figure i.e. instead of evaluating the equation at VarAddr(C) evaluate at V(C)*(1+incr)
' Y1 = Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), (V(C) - incr)))
' A(R, C) = (Y2 - Y1) / (2 * incr)
Y2 = Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), V(C) * (1 + incr)))
' value of the equation at the current variable figure i.e. instead of evaluating the equation at VarAddr(C) evaluate at V(C)*(1+incr)
Y1 = Evaluate(Application.Substitute(FormulaString(R), VarAddr(C), V(C) * (1 - incr)))
A(R, C) = (Y2 - Y1) / (2 * incr * V(C))
'
' Derivatives i.e Taylor Series approx (numerical differentiation) central difference:
' y' = (y,i+1 - y,i-1) / 2h where y' = derivative of y, h = step size
' F(x+h) = F(x) + hF'(x) thus F'(x) = [ F(x+h)-F(x) ] / h
Next C
Next R

'Augment matrix of derivatives with vector of constants.
For R = 1 To N
FormulaString(R) = Application.ConvertFormula(equations(R).Formula, xlA1, xlA1, xlAbsolute)
For C = 1 To N
FormulaString(R) = Application.Substitute(FormulaString(R), VarAddr(C), V(C))
Next C
If IsError(Evaluate(FormulaString(R))) Then MsgBox "ERROR IN FORMULA FO Augment matrix of derivatives"
A(R, N + 1) = con(R) - Evaluate(FormulaString(R))
Next R

For i = 1 To N
If Abs((A(i, N + 1)) / V(i)) > tolerance Then GoTo Refine
Next i

SimultEqNL = Application.Transpose(V)
Exit Function

Refine: Call GaussJordan3(N, A, B)
'Update V values
For i = 1 To N
V(i) = V(i) + A(i, N + 1)
Next i
'Debug.Print j, "", V(1), V(2), V(3), V(4) ', V(5), V(6), V(7), V(8), V(9)
Next j
' Exit here if no convergence after a specified number of iteration
SimultEqNL = CVErr(xlErrNA)

End Function
'. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
Sub GaussJordan3(N, AugMatrix, TempMatrix)
Dim i As Integer, j As Integer, k As Integer, L As Integer, LL As Integer, P As Integer, M As Integer, MM As Integer, MMM As Integer, MMMM As Integer
Dim pivot As Double, temp As Double, arr1() As Variant, arr2() As Variant, x As Integer, y As Integer
Dim determine As Integer, xx As Integer, yy As Integer, cntr As Integer, fudgefactor As Double
determine = 0
x = UBound(AugMatrix, 1): xx = UBound(TempMatrix, 1) ' =Number of ROWS
y = UBound(AugMatrix, 2): yy = UBound(TempMatrix, 2) ' =Number of COLUMNS' =Number of COLUMNS
' Debug.Print x, y, xx, yy
ReDim arr1(1 To 1, 1 To y): ReDim arr2(1 To 1, 1 To y)

For k = 1 To N
' Locate largest matrix element, use as pivot.
pivot = AugMatrix(k, k): P = k

For L = k + 1 To N ' loop each row

If Abs(AugMatrix(L, k)) < Abs(pivot) Then GoTo EndOfLoop

pivot = AugMatrix(L, k)

P = L
EndOfLoop: Next L ' next row
'Debug.Print pivot
' Swap rows
For j = 1 To N + 1
temp = AugMatrix(k, j)
AugMatrix(k, j) = AugMatrix(P, j)
AugMatrix(P, j) = temp
Next j

' Normalize pivot row
For j = 1 To (N + 1)
'If pivot = 0 Then MsgBox "PIVOT is ZERO"
If pivot = 0 Then Debug.Print "****",
TempMatrix(k, j) = AugMatrix(k, j) / pivot
Next j

' Do the Gauss elimination.
For i = 1 To N
If i = k Then GoTo EndOfLoop2
For j = 1 To N + 1
TempMatrix(i, j) = AugMatrix(i, j) - AugMatrix(i, k) * TempMatrix(k, j)
Next j
EndOfLoop2: Next i
For i = 1 To N
For j = 1 To N + 1
AugMatrix(i, j) = TempMatrix(i, j)
Next j
Next i
Debug.Print k, pivot
Next k
End Sub

Hi,

I've created an "application" where the user first can select one of two buttons in an excel sheet. An Add button and a Find button. The Add button displays a form (form1) where I insert some values that are inserted into one row with several columns in an excel sheet. The Find button displays a form (form2) with a multicolumn textbox list that displays some of the columns that values where inserted in earlier. I now want to be able to select a row and when I click my OK button in Form2 I want all values for that row to be displayed in my form1 for a particular row. I then want to be able to change some of the values and save those new values into the same row as there were extracted from. Right now I just display Form1 again without values. Please help. I'm a complete beginner at this.

Here I add my information
Private Sub UserForm1_Initialize()
Dim rIds As Range
Dim MaxId As Long

Set rIds = Worksheets("Systemtest").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
MaxId = Application.WorksheetFunction.Max(rIds)
With Me
.IdBox.Value = MaxId


Private Sub DateBox_Change()
   DateBox = Format(Date, "yy/mm/dd")
End Sub

Private Sub HeadingBox_Change()

End Sub

Private Sub IdBox_Change()
'   =IF(COUNTA(Systemtest[1]:Systemtest[1])=1,COUNTA(Systemtest[1]:Systemtest[1]),"""")

End Sub



Private Sub StatusBox_Change()
    StatusBox.List = Array("New", "Open", "In Progress", "Fixed", "Closed",
"Reopen", "Rejected", "Pending")
'    StatusBox.Value = "New"
End Sub

Private Sub SeverityBox_Change()
    SeverityBox.List = Array("Critical", "Major", "Normal", "Minor",
"Cosmetic", "Improvement")
'    SeverityBox.Value = "Normal"
End Sub

Private Sub EnvBox_Change()
    EnvBox.List = Array("NLL", "JLL", "NLL/JLL", "Halland")
'    SeverityBox.Value = "NLL"
End Sub

Private Sub SummaryBox_Change()

End Sub

Private Sub VersionBox_Change()
    VersionBox.List = Array("3.5.aa.1", "3.5.aa.2", "3.5.aa.3", "3.5.aa.4",
"3.5.ab.1")
'    SeverityBox.Value = "3.5.aa.1"
End Sub

Private Sub SubsysBox_Change()
    SubsysBox.List = Array("Ankomstreg (÷,S)", "Diagnosreg", "Generella", _
    "IVA", "Infektionsreg", "Integration", "Journal", "LAB",
"Lškemedel", "Lškarintyg/utl", _
    "Operation", "PAS Generella", "Pako", "Paramedicin", "Patient",
"Remisser", "RŲntgen", "System", _
    "TandvŚrdsadm", "VŚrddok", "VŚrdkontakt")
'    SubsysBox.Value = "Generella"
End Sub

Private Sub FormBox_Change()

End Sub

Private Sub TesterBox_Change()
    TesterBox.List = Array("ast", "bng", "dll", "esi", "ewalun",
"frea", "jfn", "kata", "larb", "lln", "mem", "mhd",
"mlm", "moae", "mwn", "ulwi")
'    TesterBox.Value = "ast"
End Sub

Private Sub ResponsibleBox_Change()
    ResponsibleBox.List = Array("ast", "dll", "esi", "frea", "hkn",
"jfn", "kata", "larb", "lln", "mem", "mhd", "mlm",
"moae", "mwn", "ulwi")
'    ResponsibleBox.Value = "ast"
End Sub

Private Sub FixedVerBox_Change()
    FixedVerBox.List = Array("3.5.aa.2", "3.5.aa.3", "3.5.aa.4", "3.5.ab.1",
"3.5.ab.2")
'    FixedVerBox.Value = "3.5.aa.2"
End Sub
Private Sub CommentsBox_Change()

End Sub

Private Sub ClosingBox_Change()
    ClosingBox = Format(Date, "yy/mm/dd")
End Sub


Private Sub OKButton_Click()
'   Make sure Systemtest is active
    Sheets("Systemtest").Activate
    
'   Determine the next empty row
    NextRow = _
        Application.WorksheetFunction.CountA(Range("A:A")) + 1
'   Transfer the information
    Cells(NextRow, 1) = IdBox
    Cells(NextRow, 2) = DateBox
    Cells(NextRow, 3) = StatusBox
    Cells(NextRow, 4) = ClosingBox
    Cells(NextRow, 5) = HeadingBox
    Cells(NextRow, 6) = SummaryBox
    Cells(NextRow, 7) = CommentsBox
    Cells(NextRow, 8) = TestspecBox
    Cells(NextRow, 9) = SeverityBox
    Cells(NextRow, 10) = EnvBox
    Cells(NextRow, 11) = VersionBox
    Cells(NextRow, 12) = SubsysBox
    Cells(NextRow, 13) = FormBox
    Cells(NextRow, 14) = TesterBox
    Cells(NextRow, 15) = ResponsibleBox
    Cells(NextRow, 16) = FixedVerBox
    
    
    
    
    
'   Clear the controls for the next entry
    IdBox.Text = ""
    StatusBox.Text = ""
    HeadingBox.Text = ""
    SummaryBox.Text = ""
    CommentsBox.Text = ""
    SeverityBox.Text = ""
    EnvBox.Text = ""
    VersionBox.Text = ""
    SubsysBox.Text = ""
    FormBox.Text = ""
    TestspecBox.Text = ""
'   TesterBox.Text = ""
    ResponsibleBox.Text = ""
    FixedVerBox.Text = ""
    ClosingBox.Text = ""
        
    OptionUnknown = True
    StatusBox.SetFocus
End Sub
Private Sub RegNewButton_Click()

End Sub
Private Sub CancelButton_Click()
    Unload UserForm1
End Sub
Here I have my multicolumn textbox where I select a row and click OK and naturally nothing is displayed since I just go back to my Form1 where I add my information
Private Sub UserForm_Initialize()
    'Deklarera variabler
    Dim Sh As Worksheet
    Dim Rng As Range
    Dim Cell As Range
    Dim r As Integer
    
    Set Sh = Worksheets("Systemtest")
    With Sh
        Set Rng = .Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    End With
    r = 0
    For Each Cell In Rng
        With Cell
            ListBox1.AddItem .Value
            ListBox1.List(r, 1) = .Offset(0, 1).Value
            ListBox1.List(r, 2) = .Offset(0, 2).Value
            ListBox1.List(r, 3) = .Offset(0, 4).Value
            ListBox1.List(r, 4) = .Offset(0, 5).Value
            ListBox1.List(r, 5) = .Offset(0, 7).Value
            ListBox1.List(r, 6) = .Offset(0, 12).Value
            ListBox1.List(r, 7) = .Offset(0, 14).Value
            ListBox1.List(r, 8) = .Offset(0, 13).Value
            ListBox1.List(r, 9) = .Offset(0, 15).Value
          End With
        r = r + 1
    Next Cell
End Sub

Private Sub Frame1_Click()

End Sub

Private Sub ListBox1_Click()

End Sub


Private Sub OKButton2_Click()
    UserForm1.Show
    'Dim strFind, FirstAdress As String 'what to find
    'Dim rSearch As Range 'range to search
    'Set rSearch = Systemtest.Range("A1:A" & .Cells(.Rows.Count, 1).End(xlUp).Row)
    'strFind = Me.TextBox1.Value    'what to look for
    'Dim f As Integer
    'With rSearch
     '   Set c = .Find(strFind, LookIn:=xlValues)
      '  If Not c Is Nothing Then    'found it
       '     c.Select
        '    With Me 'load entry to form
        '                ListBox1.List(r, 1) = .Offset(0, 1).Value
        '    ListBox1.List(r, 2) = .Offset(0, 2).Value
        '    ListBox1.List(r, 3) = .Offset(0, 4).Value
        '    ListBox1.List(r, 4) = .Offset(0, 5).Value
        '    ListBox1.List(r, 5) = .Offset(0, 7).Value
        '    ListBox1.List(r, 6) = .Offset(0, 12).Value
        '    ListBox1.List(r, 7) = .Offset(0, 14).Value
        '    ListBox1.List(r, 8) = .Offset(0, 13).Value
        '    ListBox1.List(r, 9) = .Offset(0, 15).Value
        '    .cmbAmend.Enabled = True    'allow amendment
        '    .cmbDelete.Enabled = Fale   'don't allow record deletion
        '    .cmbAdd.Enabled = False     'don't want duplicate record
        '    f = 0
        '    End With
End Sub

Private Sub CancelButton2_Click()
Unload UserForm2
End Sub

Private Sub UserForm_Click()

End Sub
Please help


No luck finding an answer? You could always try Google.