Hi bugs63,
Can you attach the workbook as its not clear what you need to do.
Can you include a before and after example.
Hi bugs63,
Can you attach the workbook as its not clear what you need to do.
Can you include a before and after example.
Hi zMagic,
faster variation if you have thousands of rows to delete.
Option 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
Display More
and...
Sub 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
Display More
or..
option 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
Display More
try....
Option 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
Display More
Hi 7absinth,
Consider something like ....
Option 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
Display More
addition examples of using Evaluate Function
Creating Array
Sub 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
Display More
Intersecting Array
Sub 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
Display More
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
Dim 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
Option 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
Display More
Hi F_Sadr,
you can use the index function to slice the array .. something like below
Sub 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...
Option 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
Display More
try..
Option 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
Display More
Hi another way could be to expand on ...
Option 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
Display More