Posts by pike
-
-
-
and...
Code
Display MoreSub GetNumberCollection() Dim txt As String, mytxt As String Dim j As Variant, i As Long txt = "19603" With New Collection For Each j In Split(StrConv("0123456789", 64), Chr(0)) .Add j, j Next For Each j In Split(StrConv(txt, 64), Chr(0)) .Remove j Next For i = 1 To .Count mytxt = mytxt + .Item(i) Next End With MsgBox mytxt End Sub
-
-
or..
Code
Display Moreoption explicit Sub GetNumberOther() Dim txt As String, mytxt As String Dim i As Variant, j As Long Dim blnHook As Boolean txt = "03619" For j = 0 To 9 For Each i In Split(StrConv(txt, 64), Chr(0)) If i = j Then blnHook = True End If Next i If Not blnHook Then mytxt = mytxt & j End If blnHook = False Next j MsgBox mytxt End Sub
-
-
try....
Code
Display MoreOption Explicit Sub testthree() Dim ws As Worksheet, ws2 As Worksheet, k As Long, xcell As Variant Dim db() Dim bln As Boolean With Application .DisplayAlerts = False .ScreenUpdating = False End With If Not Evaluate("IsError('NewSheet'!A1)") Then Sheets("NewSheet").Delete k = 1 Sheets.Add.Name = "NewSheet" Set ws = Worksheets("Details for we 200522") Set ws2 = Worksheets("NewSheet") With ws ReDim db(1 To Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 1 To 2) For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)) Select Case True Case xcell.Value Like "Invoice :" If xcell.Offset(, 1).Value Like "33*" Then db(k, 1) = Split(xcell.Offset(, 1).Value, " ")(0) k = k + 1 bln = True Else bln = False End If Case xcell.Value Like "UK*" And bln db(k, 1) = xcell.Value db(k, 2) = xcell.Offset(, 8).Value k = k + 1 Case Else End Select Next xcell End With ws2.Range("A1").Resize(k, 2) = db With Application .ScreenUpdating = True .DisplayAlerts = True End With End Sub
-
Hi 7absinth,
Consider something like ....
Code
Display MoreOption Explicit Sub testtwo() Dim ws, ws2 As Worksheet, k As Long, xcell As Variant Dim db() Dim strDate As String, strJob As String, strInvoice As String Application.DisplayAlerts = False Application.ScreenUpdating = False On Error Resume Next Sheets("NewSheet").Delete k = 1 Sheets.Add.Name = "NewSheet" Set ws = Worksheets("Details for we 200522") Set ws2 = Worksheets("NewSheet") With ws ReDim db(Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)).Count, 6) For Each xcell In Intersect(.Range("A:A"), .Cells.SpecialCells(xlCellTypeConstants)) Select Case True Case xcell.Value Like "Date :" strDate = xcell.Offset(, 1).Value Case xcell.Value Like "Job :" strJob = xcell.Offset(, 1).Value Case xcell.Value Like "Invoice :" strInvoice = xcell.Offset(, 1).Value Case xcell.Value Like "UK*" db(k, 0) = strDate db(k, 1) = strJob db(k, 2) = strInvoice db(k, 3) = xcell.Value db(k, 4) = xcell.Offset(, 8).Value db(k, 5) = xcell.Offset(, 9).Value k = k + 1 Case Else End Select Next xcell End With ws2.Range("A1").Resize(k, 6) = db Application.ScreenUpdating = True Application.DisplayAlerts = True End Sub
-
addition examples of using Evaluate Function
Creating Array
Code
Display MoreSub test() Dim dbArray() As Variant With Sheet1 .[a1:j14].ClearContents '1D array string conversion dbArray = [{1,2,3}] .Range("A1").Resize(1, UBound(dbArray)).Value = dbArray dbArray = [{"apple","bannana","mango"}] .Range("H1").Resize(1, UBound(dbArray)).Value = dbArray '2D array string conversion dbArray = [{1,2;3,4;5,6}] .Range("A5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray dbArray = [{1,"apple";3,"bannana";5,"mango"}] .Range("H5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray dbArray = [{1,2,3;4,5,6;7,8,9}] .Range("A10").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray '2D array string conversion with a string variable dbArray = Evaluate("{1,2;3,4;5,6}") 'have to be more explicit, the shorthand won't work .Range("E1").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray y = "{1,2;3,4;5,6}" dbArray = Evaluate(y) 'have to be more explicit, the shorthand won't work .Range("E5").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray '2D array string conversion with a string variable ' dbArray = Evaluate("1,apple;3,bannana;5,mango}") 'have to be more explicit, the shorthand won't work ' Range("E10").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray ' y = "{1,apple;3,bannana;5,mango}" ' dbArray = Evaluate(y) 'have to be more explicit, the shorthand won't work ' Range("E15").Resize(UBound(dbArray, 1), UBound(dbArray, 2)).Value = dbArray End With End Sub
Intersecting Array
Code
Display MoreSub test() Dim dbArray, myrow As Long myrow = 5 With Sheet1 dbArray = .Range("A1:I20").Value ' dummy data set With .[K1:S20] .ClearContents .Borders.LineStyle = xlNone End With With .Range("K3").Resize(3, 9) .Value2 = Application.Index(dbArray, Evaluate("ROW(3:" & myrow & ")"), Application.Transpose([row(1:9)])) .Borders.Weight = 2 End With With .[L7].Resize(4, 7) .Value2 = Application.Index(dbArray, [Row(7:11)], Application.Transpose([row(2:8)])) .Borders.Weight = 2 End With With .Range("N16").Resize(5, 6) .Value2 = Application.Index(dbArray, Evaluate("ROW(16:20)"), Application.Transpose([row(4:9)])) .Borders.Weight = 2 End With End With ' With result = MsgBox("Table Count :" & myrow, vbOKCancel, "Table Count") ' With Results = InputBox("Table Count :" & myrow, vbOKCancel, "Table Count") ' MsgBox Results ' End With ' End With End Sub
-
-
Hi,
column works.. thinking i was using evaluate function when the rows or columns were dynamic and used [ ] where the array was fixed
with test array
CodeDim dbArray, myrow As Long myrow = 5 With Sheet3 dbArray = .Range("A1:I20").Value .[K1:S20].ClearContents .Range("K2").Resize(5, 9) = Application.Index(dbArray, Evaluate("ROW(1:" & myrow & ")"), Application.Transpose([row(1:9)])) .[K9].Resize(5, 9) = Application.Index(dbArray, [ROW(6:11)], Application.Transpose([row(1:9)])) .Range("K16").Resize(5, 9) = Application.Index(dbArray, Evaluate("ROW(16:20)"), [column(1:9)]) End With
-
Hi F_Sadr,
Have a look at the link below for explanation on evaluate.
Evaluate - Most Power Function in VBA?
I can't remember why i didn't use Column. Give it a try.
-
with skip lines for the data sets only
Code
Display MoreOption Explicit Sub ImportLPileTextFile() Dim myFile As String, txtLine As String, blnCopy As Boolean, nRow As Long, eCol As Long, iCount As Long myFile = Application.GetOpenFilename() eCol = -2 Open myFile For Input As #1 Do Until EOF(1) Line Input #1, txtLine If txtLine Like " y, inches p, lbs/in " Then blnCopy = True eCol = eCol + 3 iCount = 1 ElseIf Len(txtLine) < 1 Then blnCopy = False nRow = 1 iCount = 0 Else iCount = iCount + 1 End If If blnCopy And iCount > 2 Then Sheet1.Cells(nRow, eCol).Value = Trim(Right(txtLine, 16)) Sheet1.Cells(nRow, eCol + 1).Value = Trim(Left(txtLine, 16)) nRow = nRow + 1 End If Loop Close #1 MsgBox "Table Count :" & (eCol + 2) / 3, vbInformation, "Table Count" End Sub
-
Hi F_Sadr,
you can use the index function to slice the array .. something like below
CodeSub test() With Sheet1 .Cells(1, 1).Resize(1000000, 250) = Application.index(DataCache, Evaluate("ROW(1:1000000)"), Application.Transpose([row(1:250)])) End With With Sheet2 .Cells(1, 1).Resize(1000000, 250) = Application.index(DataCache, Evaluate("ROW(1000001:2000001)"), Application.Transpose([row(1:250)])) End With End Sub
-
Try...
Code
Display MoreOption Explicit Sub ImportLPileTextFile() Dim myFile As String, txtLine As String, blnCopy As Boolean, n As Long, e As Long myFile = Application.GetOpenFilename() e = 1 Open myFile For Input As #1 Do Until EOF(1) Line Input #1, txtLine If txtLine Like " y, inches p, lbs/in " Then blnCopy = True e = e + 3 ElseIf Len(txtLine) < 1 Then blnCopy = False n = 1 End If If blnCopy Then n = n + 1 Cells(n, e - 2).Value = Trim(Right(txtLine, 18)) Cells(n, e - 3).Value = Trim(Left(txtLine, 18)) End If Loop Close #1 MsgBox "Table Count :" & (e - 1) / 3, vbInformation, "Table Count" End Sub
-
try..
Code
Display MoreOption Explicit Sub testshet() Dim a, b(), i As Long, n As Long, dic1, w, e As Long With Range("a1").CurrentRegion a = .Resize(, 3).Value ReDim b(1 To UBound(a, 1), 1 To UBound(a, 1) * 2) End With Set dic1 = CreateObject("Scripting.Dictionary") dic1.CompareMode = vbTextCompare For i = 1 To UBound(a, 1) If Not dic1.Exists(a(i, 1)) Then n = n + 1 dic1.Add a(i, 1), Array(n, 2) b(n, 1) = a(i, 1) b(n, 2) = a(i, 2) b(n, 3) = a(i, 3) Else w = dic1(a(i, 1)) w(1) = w(1) + 2 b(w(0), w(1)) = a(i, 2) b(w(0), w(1) + 1) = a(i, 3) e = Application.Max(w(1), e) dic1(a(i, 1)) = w End If Next Range("e1").Resize(n, e + 1).Value = b End Sub
-
Hi another way could be to expand on ...
Code
Display MoreOption Explicit Sub testi() Dim a(), b(), i As Long, n As Long, t As Long, w, e, u Dim dic1 As Object, dic2 As Object Set dic1 = CreateObject("Scripting.Dictionary") dic1.CompareMode = vbTextCompare Set dic2 = CreateObject("Scripting.Dictionary") dic2.CompareMode = vbTextCompare With Sheet3 a = .Range("a1").CurrentRegion.Resize(, 7).Value End With n = 1 t = 1 ReDim b(1 To UBound(a, 1), 1 To 14) For i = 2 To UBound(a, 1) If Not dic1.exists(Format(a(i, 1), "mmmm")) Then t = t + 1 dic1.Add Format(a(i, 1), "mmmm"), Array(t, a(i, 7)) b(1, t) = Format(a(i, 1), "mmmm") Else w = dic1(Format(a(i, 1), "mmmm")) w(1) = w(1) + a(i, 7) dic1(Format(a(i, 1), "mmmm")) = w End If If Not dic2.exists(a(i, 4)) Then n = n + 1 dic2.Add a(i, 4), Array(n, a(i, 7)) b(n, 1) = a(i, 4) Else u = dic2(a(i, 4)) u(1) = u(1) + a(i, 7) dic2(a(i, 4)) = u End If b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) = b(dic2(a(i, 4))(0), dic1(Format(a(i, 1), "mmmm"))(0)) + a(i, 7) Next For Each e In dic1.keys w = dic1.Item(e) b(n + 1, w(0)) = w(1) b(n + 1, t + 1) = b(n + 1, t + 1) + w(1) Next For Each e In dic2.keys u = dic2.Item(e) b(u(0), t + 1) = u(1) Next With Sheet2 .UsedRange.Clear With .Range("a1").Resize(n + 1, t + 1) .Value = b .Borders.Weight = 2 End With End With End Sub
-
If you can do it in a Power Query and the table layout is acceptable the Power Query is exceptionally fast!
-
-
hi Littlepete,
There is no worksheet OnExit event but try
Code
Display MoreOption Explicit Dim PrevCell As Range Private Sub Worksheet_SelectionChange(ByVal Target As Range) If Not PrevCell Is Nothing Then With PrevCell .Font.Bold = False 'PrevCell.BorderAround LineStyle:=xlNone, Weight:=xlThin, ColorIndex:=xlNone .Borders(xlDiagonalDown).LineStyle = xlNone .Borders(xlDiagonalUp).LineStyle = xlNone .Borders(xlEdgeLeft).LineStyle = xlNone .Borders(xlEdgeTop).LineStyle = xlNone .Borders(xlEdgeBottom).LineStyle = xlNone .Borders(xlEdgeRight).LineStyle = xlNone .Borders(xlInsideVertical).LineStyle = xlNone .Borders(xlInsideHorizontal).LineStyle = xlNone End With End If With Target .Font.Bold = True .BorderAround ColorIndex:=5, Weight:=xlThick End With 'Target.Borders.LineStyle = Excel.XlLineStyle.xlLineStyleNone Set PrevCell = Target End Sub