Posts by apo

apo · Dec 28th 2018

HI.. Here's another one to try..

It would be interesting to see which one is faster.. probably KJ's as although there is an extra loop.. it's all array based.

Code

Private Sub CommandButton1_Click()
    Dim x, y, i As Long, strRows As String
    With Sheets("Combined").[A1].CurrentRegion
        x = .Value
        For i = LBound(x) To UBound(x)
            If Not x(i, 10) Like "###[-]###[-]#" Or x(i, 10) = "" _
                Or x(i, 10) Like "[9]##[-]###[-]#" Then strRows = strRows & " " & i
        Next i
               With Sheets("CheckAccts")
                    y = Application.Index(x, Split(Trim(strRows)), Evaluate("row(1:" & UBound(x, 2) & ")"))
                    .[A1].Resize(UBound(y, 2), UBound(y)) = Application.Transpose(y)
                    .Columns.AutoFit
                End With
    End With
End Sub

Display More

apo · Dec 27th 2018

Hi..

Here's something you can adapt... it just puts a border around every cell containing a constant on the Sheet change Event.

So if are entering anything other than a constant (likeFormulas).. then this one is no good. (Paste it into your sheet code)

Code

Private Sub Worksheet_Change(ByVal Target As Range)
 With Cells.SpecialCells(2)
  .BorderAround ColorIndex:=1, Weight:=xlThin
  .Borders(xlInsideHorizontal).LineStyle = xlContinuous
  .Borders(xlInsideVertical).LineStyle = xlContinuous
 End With
End Sub

Another option would be to use the Range.Areas Property and loop through each Area in your used range and apply a border to the whole area similarly to how it is applied above.

Depending on how much data you have.. you could either put it again on the sheet change event or have a button to press that applies it at the users will.

apo · Dec 24th 2018

Hi.. late to the party.. but just for fun.. maybe something like this too could work..

Code

Private Sub CommandButton1_Click()
    Dim x, lr As Long, i As Long
    x = Sheets("input").Cells(1).CurrentRegion.Resize(, Sheets("input").Cells(1).CurrentRegion.Columns.Count + 1)
    For i = 1 To UBound(x, 2) - 10
        lr = Sheets("Test").Range("A" & Rows.Count).End(xlUp).Row + 1
        Sheets("Test").Cells(lr, 1).Resize(UBound(x) - 1, 11) = Application.Index(x, Evaluate("row(2:" & UBound(x) & ")"), Array(1, 2, 3, 4, 5, 6, 7, 8, 9, UBound(x, 2), 9 + i))
        Sheets("Test").Cells(lr, 10).Resize(UBound(x) - 1, 1) = Application.Transpose(x(1, 9 + i))
    Next i
End Sub

apo · Oct 26th 2018

And with my one,

Change:

Code

Cells(i, 6).Value = Cells(i, 4) - Cells(i, 5)

to

Code

Cells(i, 6).Formula = "=(D" & i & "-E" & i & ")"

apo · Oct 25th 2018

Here's another possibility, if your Workbook remains the same format as the one you uploaded..

Code

Private Sub CommandButton1_Click()
    Dim i As Long, sRow As Long, gtString As String
    For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    
        Select Case Cells(i, 3).Value
        
            Case "Asset", "Liability", "Fund Balance", "Encumbrance", "Expenditure", "Revenue"
            Cells(i, 6).Value = Cells(i, 4) - Cells(i, 5)
        End Select
        
        If Left(Cells(i, 1), 13) = "Balance Sheet" Then
            sRow = i + 1
        End If
        
        Select Case Left(Cells(i, 1), 5)
        
            Case "Total"
            Cells(i, 4).Formula = "=SubTotal(9,D" & sRow & ":" & "D" & i - 1 & ")"
            Cells(i, 4).AutoFill Destination:=Range(Cells(i, 4), Cells(i, 6))
            If gtString = "" Then
                gtString = "D" & i
            Else
                gtString = gtString & "," & "D" & i
            End If
            
            Case "Grand"
            Cells(i, 4).Formula = "=Sum(" & gtString & ")"
            Cells(i, 4).AutoFill Destination:=Range(Cells(i, 4), Cells(i, 6))
        End Select
    Next i
End Sub

Display More

apo · Jun 21st 2018

Hi..

Try using the method shown by Pike in post #5 of this thread:

https://www.ozgrid.com/forum/f…-sorting-its-product-list

apo · Jun 21st 2018

Hi.. Welcome to Ozgrid..

You didn't say what happens to column C.. so here's 2 versions..

Version 1: Column C becomes the last column (column F).

Code

Private Sub CommandButton1_Click()
Dim x
With Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row)
   x = .Value
   .Value = Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), Array(6, 4, 5, 2, 1, 3))
End With
End Sub

Version 2: Column C is not wanted... which brings in the need to clear the existing range and set the size of the range that the values will be dumped into.

Code

Private Sub CommandButton2_Click()
Dim x
With Range("A1:F" & Range("A" & Rows.Count).End(xlUp).Row)
   x = .Value
   .ClearContents
   [A1].Resize(UBound(x), UBound(x, 2) - 1).Value = Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), Array(6, 4, 5, 2, 1))
End With
End Sub

More Info:
http://www.snb-vba.eu/VBA_Arrays_en.html#L_6

apo · Jun 20th 2018

Hi..

Here's another that works on your sample (although you MUST remove the text "End" that was in row 15000 (the black row) on each of you DBEntry sheets.. not sure why that was there.. and it makes it hard to find the last used row of data..

The idea below is to read each Workbook once, add data to Collection and build array, then dump array to sheet.. so as little sheet interactions as possible.

I haven't played with Collections much at all, but found Pikes thread on it valuable.. https://www.ozgrid.com/forum/f…excel-vba-collection-sort

It seems you can't dump a Collection straight to sheet( like you would an array)so that's why the extra step of building the array from the Collection is needed..

Code

Private Sub CommandButton1_Click()
    Dim myList As New Collection, myItem
    Dim x, xx, y, SelFold As String, i As Long, ii As Long, iii As Long, k As Long, kk As Long


    SelFold = "C:\Users\cowen\Documents\Yield Tracker V2"
    x = Split(CreateObject("wscript.shell").exec("cmd /c Dir """ & SelFold & "\*.xls*"" /s/b").stdout.readall, vbCrLf)
 
    Set myItem = New Collection
    
    For i = LBound(x) To UBound(x) - 1
    
        With GetObject(x(i))
            xx = .Sheets("DBEntry").Range("B3:S" & .Sheets("DBEntry").Range("B" & Rows.Count).End(xlUp).Row)
            For ii = LBound(xx) To UBound(xx)
                If xx(ii, 1) <> "" Then
                    For iii = LBound(xx, 2) To UBound(xx, 2)
                        
                        myItem.Add Item:=xx(ii, iii)
                    Next iii
                    myList.Add Item:=myItem
                End If
                Set myItem = New Collection
            Next ii
            .Close
        End With
        
    Next i
    
    ReDim y(1 To myList.Count, 1 To 18)
    For k = 1 To myList.Count
        For kk = 1 To 18
            y(k, kk) = myList(k).Item(kk)
        Next kk
    Next k
    Sheets("DBEntry").[B3].Resize(UBound(y), UBound(y, 2)) = y
    Set fldr = Nothing
End Sub

Display More

apo · Jun 15th 2018

Naughty cross poster.. ;/

Not sure why you would just want to select those cells.. if your going to do anything with them.. selecting them is probably the least efficient way of including them..

Any way.. there is MOST probably a better regex pattern.. but this seems to work..

Code

Private Sub CommandButton1_Click()
    Dim i As Long, rRngToSelect As Range
    With CreateObject("vbscript.regexp")
        .Pattern = "(\b[1]\b)"
        For i = 1 To Range("D" & Rows.Count).End(xlUp).Row
            If .Execute(Cells(i, 4)).Count > 0 Then
                            If rRngToSelect Is Nothing Then
                Set rRngToSelect = Range("D" & i)
            Else
                Set rRngToSelect = Union(rRngToSelect, Range("D" & i))
            End If
            End If
        Next i
    End With
rRngToSelect.Select
End Sub

Display More

apo · Jun 13th 2018

Just a thought.. maybe add a "Search" textbox so you can get to the wanted item faster..

You could set the z variable to be a range (column 1 in the "Database" sheet).. or make it a Public variable and assign Pikes array to it..

I have attached a Workbook showing kinda what i mean.. enter some text in the "Enter Item" textbox to populate the combobox.. also.. pressing the Tab key while in the textbox will populate the combo with all values (so you can scroll I guess). double click in combo shows selected item.

The way I populated the z array is a bit dodgy though.. I used Scripting Dictionary to find uniques then fed it into an arraylist and sorted... Pikes way it better.

btw.. here is some good stuff right here: https://www.ozgrid.com/forum/f…ctions-arraylist?t=167349

Code

Sub Listit()
    Dim e
    With Sheets("PickaProduct")
        .ListBox1.Clear
        
        If Len(.TextBox1.Value) Then
            For Each e In z
                If (e <> "") * (e Like "*" & UCase(.TextBox1.Value) & "*") Then
                 .ListBox1.AddItem e
                End If
            Next
            With .ListBox1
                If .ListCount > 0 Then .ListIndex = 0
            End With
        End If
    End With
End Sub

Display More

apo · Jun 7th 2018

Hi..

Probably shouldn't Dimensions variable for a lastrow as an INteger.. as it has a max value of 32767.. better to dim it as long.
"
Also.. you should specify explicitly the sheet that "Rows.Count" is referring to.... like "....Cells(Sheets("Previous Period DT37").Rows.Count,1)......."

apo · Jun 7th 2018

Hi..

Here's another.. click the blue button to test,

I am not sure what you want to do in the "Do stuff here" part.. but you could also add validation that the user has opened the correct file etc before executing any other code..

Code

Private Sub CommandButton1_Click()
    Dim X, Z, it, i As Long, strFile
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For Each it In Range("A2:A" & Range("A" & Rows.Count).End(xlUp).Row)
            X = .Item(Format(it.Value, "DD/MM/YYYY"))
        Next
        Z = .keys
    End With
    
    For i = LBound(Z) To UBound(Z)
        
        strFile = Application.GetOpenFilename("Excel Workbooks,*.xls*", , "Please choose the " & Z(i) & " file")
        
        ''''' Do Your stuff here ''''''
        
    Next i
End Sub

Display More

apo · Jun 7th 2018

Hi..

Bit rusty.. but maybe something like this?

Click the blue button on sheet1 to test..

Edit: I didn't see the part about inserting "No Match".. added in red.. add that to the sample workbook to test..

Code

Private Sub CommandButton1_Click()
    Dim x, valsArray, i As Long, ii As Long
    x = Sheets("Sheet1").Range("A1:J" & Range("E" & Rows.Count).End(xlUp).Row)
    valsArray = Array("0|2", "1|4", "2|7", "5|3", "6|6", "11|10")
    
    Application.ScreenUpdating = False
    With Sheets("Sheet2").Range("A1:M" & Sheets("Sheet2").Range("J" & Rows.Count).End(xlUp).Row)
        .Parent.Select


        For i = 2 To UBound(x)
            .AutoFilter 10, x(i, 5)
            
            With ActiveSheet.AutoFilter.Range
                If .SpecialCells(12).Count > 13 Then
                    With .Range("B" & .Offset(1).SpecialCells(12)(1).Row)
                        For ii = LBound(valsArray) To UBound(valsArray)
                            .Offset(, Split(valsArray(ii), "|")(0)).Value = x(i, Split(valsArray(ii), "|")(1))
                            .Offset(, Split(valsArray(ii), "|")(0)).Interior.ColorIndex = 4
                        Next ii
                    End With
                   [B][COLOR=#FF0000]  Else
                    Sheets("Sheet1").Cells(i, 1).Value = "No Match" [/COLOR] [/B]  
                End If
            End With
        Next i


        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Display More

apo · Mar 14th 2018

Hi..

You should really create a new thread.. it helps when others are searching for the same solution..

Your code wasn't getting all the data you wanted because you were using xlDown instead of Xlup..

In any case.. try this:

Code

Sub Copy_Columns()
Dim x
 x = Sheets("HomeWork").Range("A4:H" & Sheets("HomeWork").Range("A" & Rows.Count).End(xlUp).Row)
 Sheets("NavInv").[C2].Resize(UBound(x, 1), 5).Value = Application.Index(x, Evaluate("row(1:" & UBound(x) & ")"), Array(1, 3, 4, 2, 5))
End Sub

btw.. Also post your code within the code tags.. it's the little hash symbol on the edit bar..

apo · Jul 23rd 2017

Re: Excel Vba to transpose single row to multiple columns

Here's another...

Code

Private Sub CommandButton1_Click()
    Dim x, xx, cnt1 As Long, cnt2 As Long, i As Long, ii As Long
    [C8].CurrentRegion.ClearContents
    x = [C5].CurrentRegion: cnt1 = 1: cnt2 = 1
    ReDim xx(1 To UBound(x, 2) / 3, 1 To 3)
    For i = 1 To UBound(x, 2) / 3
        For ii = 1 To 3
            xx(cnt1, ii) = x(1, cnt2)
            cnt2 = cnt2 + 1
        Next ii
        cnt1 = cnt1 + 1
    Next i
    [C8].Resize(UBound(xx, 1), UBound(xx, 2)).Value = xx
End Sub

Display More

apo · Jul 17th 2017

Re: uppper, proper case & font/size

Something like..

Code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Target.Worksheet.Range("D6:E14")) Is Nothing Then
        Target.Value = UCase(Target.Value)
        Target.Font.Name = "Calibri"
        Target.Font.Size = 10
    End If
    If Not Intersect(Target, Target.Worksheet.Range("K6:K14")) Is Nothing Then
        Target.Value = Application.Proper(Target.Value)
        Target.Font.Name = "Calibri"
        Target.Font.Size = 10
    End If
End Sub

Display More

apo · Jul 17th 2017

Re: New Macro or Code to Move Rows to Another Sheet Based on Cell Value

HI.. Try this.

Code

Private Sub CommandButton1_Click()
    Dim x, cnt1 As Long, cnt2 As Long, strRows As String, strRows2 As String, i As Long
    With [A1].CurrentRegion
        x = .Value
        .ClearContents
    End With
    cnt1 = 1: cnt2 = 1: strRows = "1": strRows2 = "1"
    For i = LBound(x) + 1 To UBound(x)
        If x(i, 1) = "PROG001" Then
            strRows = strRows & " " & i: cnt1 = cnt1 + 1
        Else
            strRows2 = strRows2 & " " & i: cnt2 = cnt2 + 1
        End If
    Next i
    Sheets("1st Placements").[A1].Resize(cnt1, 4).Value = Application.Transpose(Application.Index(x, Split(Trim(strRows)), Evaluate("row(1:4" & ")")))
    Sheets("2nd Placements").[A1].Resize(cnt2, 4).Value = Application.Transpose(Application.Index(x, Split(Trim(strRows2)), Evaluate("row(1:4" & ")")))
End Sub

Display More

apo · May 7th 2017

Re: Importing multiple text files with names into excel (different rows)

Hi.. welcome to Ozgrid.

If all your txt files have the same format.. maybe this also..

Code

Private Sub CommandButton1_Click()
    Dim arrFile, i As Long, s, getValArray, ii As Long, y()
    [A1].Resize(, 9) = Array("Name", "Type", "Circt", "Speed", "Route", "Route2", "Route3", "Route4", "Route5")
    arrFile = Application.GetOpenFilename("Text Files,*.txt", MultiSelect:=True)
    If IsArray(arrFile) Then
        For i = LBound(arrFile) To UBound(arrFile)
            s = Split(CreateObject("scripting.filesystemobject").getfile(arrFile(i)).openastextstream.readall, vbLf)
            getValArray = Array(Split(Split(arrFile(i), "\")(UBound(Split(arrFile(i), "\"))), ".")(0), 0, 1, 2, 8, 9, 10, 11, 12)
            ReDim Preserve y(1 To 9, 1 To i)
            For ii = 2 To UBound(getValArray) + 1
                y(1, i) = getValArray(0): y(ii, i) = Split(s(getValArray(ii - 1)), ":")(1)
            Next ii
        Next i
    End If
    Range("A" & Range("A" & Rows.Count).End(xlUp).Row).Offset(1).Resize(UBound(y, 2), 9) = Application.Transpose(y)
End Sub

Display More

apo · Mar 20th 2017

Re: Macro Code to delete specific data in specific columns

Hi..

Another way would be to use Autofilter.. no loop needed..

Code

Private Sub CommandButton1_Click()
    Application.ScreenUpdating = False
    With [A1].CurrentRegion
        .AutoFilter 3, "Africa"
        .AutoFilter 4, "Information"
        .Parent.AutoFilter.Range.Rows.Offset(1).Resize(.Parent.AutoFilter.Range.Rows.Count - 1).SpecialCells(12).EntireRow.Delete
        .AutoFilter
    End With
    Application.ScreenUpdating = True
End Sub

Also.. London.. take a look at the Union method.. it allows you to build a range as you loop and then do something with that range at the end (like delete or copy etc).. it will be faster as there is less sheet interaction..

apo · Mar 17th 2017

Re: Import codes from once sheet to the other

Hi..

Please put code tags around any code you post. (When in the Reply box.. highlight your code and click the little # icon in the Reply box menu bar). I have done it for you in your last post.

Code

Sub ImportProdCode()
    Dim x, i As Long, cnt As Long
    x = Application.Transpose(Sheets("SubstoreBuyPlan").Range("A2:A" & Sheets("SubstoreBuyPlan").Range("A" & Rows.Count).End(xlUp).Row))
    cnt = 1
    For i = LBound(x) To UBound(x)
        Sheets("SubstoreProductMaster").Cells(i + cnt, 1).Value = x(i)
        cnt = cnt + 24
    Next i
End Sub

You had a couple of issues when you adapted the code i gave you.

1. The way you are referencing your Worksheets would require you to Declare and Set them first. I may have confused you in that the way I referenced them in the initial code was by the sheets index number. IN the second code I show how to reference it by sheet name (one way)..

2. Your missing the part where you should turn screenupdating to False at the start of your code.

3. Not that I think you need to do this.. but you are setting the calculation mode to automatic at the end but not setting it to manual at the start.. so it is pointless.

Lemme know how you go.

Posts by apo

Macro to copy rows to another worksheet if a cell matches a specific format

Auto Border if Text is Present

Macro to Combine Data from Multiple Columns and Label Rows with Original Headers

Calculating subtotal and grand total in VBA

Calculating subtotal and grand total in VBA

ComboBox Duplicate error

Realign columns to match the headings from other file.

Merge Multiple Ranges of Data

select rows that has particular number in Col D

Combobox code is not sorting its product list

Last Row not being found

Run through a column to get number of unique dates and store as a variabl

If Cell's Match, copy specific cells in ws 1 to ws 2.

Copying rows from one sheet to another excluding "empty" rows

Excel Vba to transpose single row to multiple columns

uppper, proper case & font/size

New Macro or Code to Move Rows to Another Sheet Based on Cell Value

Importing multiple text files with names into excel (different rows)

Macro Code to delete specific data in specific columns

Import codes from once sheet to the other