they may mean to add reference the scripting run time library
Posts by pike
-
-
Hi d6677g,
There are no windows API ( Application Program Interface) calls to update from 32 to 64 bit in your syntax.
the code will run in either environment.
If there are errors, it is because of missing worksheets or workbook or paths ect...
-
Hi All,
Interesting problem i recently had with CSV files to Array syntax i usually use...
Code
Display MoreOption Explicit Sub CVStoArray1() Dim dbArrayConst, dbRowConst As Long, dbColConst As Long, strlFilePathName As String strlFilePathName = Application.GetOpenFileName("Text Files (*.csv),*.csv", , "Select CSV file...") With Workbooks.Open(Filename:=strlFilePathName) dbArrayConst = .Sheets(1).UsedRange.Value2 .Close End With MsgBox "Lowerbound " & LBound(dbArrayConst) dbRowConst = UBound(dbArrayConst) dbColConst = UBound(dbArrayConst, 2) MsgBox "Rows " & dbRowConst & " Columns " & dbColConst End Sub
The above method will be ok If you dont have numbers with leading zero's as they will be lost
Example line from CSV file with ten columns but is complicated with commas between quotation.
"012,034 ABCDE,,,"EFG,56,,,HIJ,,KLMN",,56"OP,QR,ST,",07890,UVWXYZ,"
Rewritten for the VBA Module
"012,034 ABCDE,,,""EFG,56,,,HIJ,,KLMN"",,56""OP,QR,ST,"",07890,UVWXYZ,"
Reg Ex Example to replace comma between quotations with Pipes
Code
Display MoreSub SpltCmm1() Dim strLine As String Dim m strLine = "012,034 ABCDE,,,""EFG,56,,,HIJ,,KLMN"",,56""OP,QR,ST,"",07890,UVWXYZ," With CreateObject("VBScript.RegExp") .Pattern = """[^""," & Chr(2) & "]+,[^""" & Chr(2) & "]+""" Do While .test(strLine) Set m = .Execute(strLine)(0) Mid$(strLine, m.FirstIndex + 1, m.Length) = Replace(m.Value, ",", "|") Loop End With MsgBox strLine End Sub
VBA example
Code
Display MoreSub SpltCmm2() Dim lngb As Long, lngz As Long, strLine As String strLine = "012,034 ABCDE,,,""EFG,56,,,HIJ,,KLMN"",,56""OP,QR,ST,"",07890,UVWXYZ," lngb = InStr(strLine, Chr(34)) lngz = InStr(lngb + 1, strLine, Chr(34)) strLine = Mid(strLine, 1, lngb - 1) & Replace(Mid(strLine, lngb + 1, lngz - lngb - 1), ",", "|") & Mid(strLine, lngz + 1) MsgBox strLine End Sub
Putting it all together
Example two
Code
Display MoreSub CVStoArray2() Dim dbArrayConst, dbRowConst As Long, dbColConst As Long, strlFilePathName As String strlFilePathName = Application.GetOpenFileName("Text Files (*.csv),*.csv", , "Select CSV file...") dbCSVArray strlFilePathName, dbArrayConst MsgBox "Lowerbound " & LBound(dbArrayConst) dbRowConst = UBound(dbArrayConst) dbColConst = UBound(dbArrayConst, 2) MsgBox "Rows " & dbRowConst & " Columns " & dbColConst End Sub Function dbCSVArray(ByRef strfile As String, ByRef CSVArray As Variant) As Boolean Dim objFSO As FileSystemObject, objStream As TextStream Dim dbLine As String, objLine As String, dbArray As Variant Dim LineCnt As Long, ColCnt As Long, n As Long, e As Long dbCSVArray = False Set objFSO = CreateObject("Scripting.FilesystemObject") Set objStream = objFSO.OpenTextFile(strfile) LineCnt = 0 ColCnt = 0 While Not objStream.AtEndOfStream objLine = objStream.ReadLine If InStr(1, objLine, Chr(34)) > 0 Then dbLine = SpltCmm(objLine) Else dbLine = objLine End If LineCnt = LineCnt + 1 ColCnt = WorksheetFunction.Max(ColCnt, UBound(Split(dbLine, ",")), Len(dbLine) - Len(Replace(dbLine, ",", ""))) Wend objStream.Close ReDim CSVArray(1 To LineCnt + 1, 1 To ColCnt + 1) If LineCnt > 1 And ColCnt > 1 Then dbCSVArray = True End If Set objStream = objFSO.OpenTextFile(strfile) e = 0 While Not objStream.AtEndOfStream objLine = objStream.ReadLine If InStr(1, objLine, """") > 0 Then dbLine = SpltCmm(objLine) Else dbLine = objLine End If dbArray = Split(dbLine, ",") e = e + 1 For n = 0 To UBound(dbArray) CSVArray(e, n + 1) = dbArray(n) Next n Wend Set objStream = Nothing Set objFSO = Nothing End Function Function SpltCmm(strLine As String) As String Dim matches With CreateObject("VBScript.RegExp") .Pattern = """[^""," & Chr(2) & "]+,[^""" & Chr(2) & "]+""" Do While .test(strLine) Set matches = .Execute(strLine)(0) Mid$(strLine, matches.FirstIndex + 1, matches.Length) = Replace(matches.Value, ",", Chr(124)) Loop End With SpltCmm = strLine End Function
The Pipe's can be removed from the work sheet with something like
CodeWith .UsedRange .Replace What:="|", Replacement:=",", SearchOrder:=xlByColumns, MatchCase:=True
Hope this helps...
-
Hi bugs63,
Can you attach the workbook as its not clear what you need to do.
Can you include a before and after example.
-
Hardly a newbie or treaded badly ... it was excellent advice for getting your thread answered.
Dave Hawley was not one to fluff around if you couldn't apply the rules and requirements on how to add a title and script your question.
-
Hi zMagic,
faster variation if you have thousands of rows to delete.
Code
Display MoreOption Explicit Sub ptest() Dim dRange As Range Dim dRow As Long For dRow = 1 To Cells(Rows.Count, "C").End(xlUp).Row If Not Cells(dRow, "C") Like "CCODE -/00###/*" Then If dRange Is Nothing Then Set dRange = Cells(dRow, "C") Else Set dRange = Union(dRange, Cells(dRow, "C")) End If End If Next dRow If Not dRange Is Nothing Then dRange.EntireRow.Delete End Sub
-
-
-
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