I have an excel file with one column with data. Something like:
21/07/2017
DEF
GHI
Field 7
SOMETHING HERE
MORE TEXT
21/07/2017
DEF
GHI
Field 7
This is repeated a few thousand times. What I am looking for is all rows between and including 21/07/2017 and Field 7 to be deleted and for the rows to be moved up.
I've tried a few things but now back to a blank canvas! Any hints?
Thanks
CODE I TRIED
I get an Overflow error
Sub deleteRows()
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
RowCount = 1
Application.DisplayAlerts = False
Set sh = ActiveSheet
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "21/07/2017" Then
a = RowCount
End If
If sh.Cells(rw.Row, 1).Value = "Field 7" Then
b = RowCount
Rows(a & ":" & b).Delete
End If
RowCount = RowCount + 1
Next rw
End Sub
This will only loop as many times as the pair exists and delete each block as a whole.
The loop ends the first time that both are not found in the remaining values.
Sub myDelete()
Dim str1 As string
Dim str2 As String
Dim rng As Range
Dim ws As Worksheet
Dim i As Long
Dim j As Long
str1 = "21/07/2017"
str2 = "Field 7"
Set ws = Worksheets("Sheet18") 'change to your worksheet
Set rng = ws.Range("A:A")
Do
i = 0: j = 0
On Error Resume Next
i = Application.WorksheetFunction.Match(str1, rng, 0)
j = Application.WorksheetFunction.Match(str2, rng, 0)
On Error GoTo 0
If i > 0 And j > 0 Then
ws.Rows(i & ":" & j).Delete
End If
Loop Until i = 0 Or j = 0
End Sub
If your date is a true date then change str1 to Double:
Dim str1 As Double
and then assign it as such:
str1 = CDbl(DateSerial(2017, 7, 21))
Related
I am working with a schedule, that I have imported and formatted into my workbook.
I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox.
I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells.
My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE)
(See picture)
I have code but its more me trouble-shooting than an actual semi working script.
Dim shT As Worksheet
Dim schnumrng1 As Range
Dim schnumrng2 As Range
Dim schnumrng3 As Range
Dim schnumrng4 As Range
Dim schnumrng5 As Range
Dim schpersonrng As Range
Dim schphaserng As Range
Dim schlistrng As Range
Dim maxschnum
Dim schstatus
Dim schperson
Dim schlistnum
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim rng As Range
Dim cl As Range
Dim lc
'allowevents = True
''Set Screen parameters
'Application.ScreenUpdating = False
'Application.EnableEvents = False
'
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
Set schnumrng = Range("B5", "B" & maxschnum)
'Set Ranges for the list box
Set schnumrng1 = Range("A5", "A" & maxschnum)
Set schnumrng2 = Range("B5", "B" & maxschnum)
Set schnumrng3 = Range("D5", "D" & maxschnum)
Set schnumrng4 = Range("E5", "E" & maxschnum)
Set schnumrng5 = Range("F5", "F" & maxschnum)
'This is static and not moving to the next line in my for statement / switched to named ranges and errors
Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5
'Set rng = Range("A5,B5,D5,E5,F5")
i = 1
j = 1
For Each lc In schnumrng
If lc <> vbNullString Then
For Each cl In rng
ReDim Preserve Ar(1, 1 To i)
Ar(j, i) = cl.Value
i = i + 1
Next cl
Else
End If
j = j + 1
Next lc
With ScheduleForm.SchMainTasklt
.ColumnCount = i - 1
.ColumnWidths = "50;150;50;50;50"
.List = Ar
End With
My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well.
First, only the data in column b, not empty cells, is extracted from listbox1.
Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value.
Module Code
Place this code in the module. This is because global variables must be used.
Public vDB As Variant
Public Dic As Object 'Dictionary
Sub test()
Dim shT As Worksheet
Dim maxschnum As Long
Dim Ar() As String
Dim i As Long
Dim j As Long
Dim vC() As Variant
Dim cnt As Integer, n As Integer
Dim c As Integer
Dim s As String, s2 As String
Worksheets("Schedule").Visible = True
ThisWorkbook.Worksheets("Schedule").Activate
'
Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary
Set shT = Worksheets("Schedule")
maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row
With shT
vDB = .Range("a5", .Range("f" & maxschnum))
End With
'vC is data colum A,B,D,E,F
vC = Array(1, 2, 4, 5, 6)
s2 = vDB(2, 2)
For i = 2 To UBound(vDB, 1)
s = vDB(i, 2) 'column B
If s = "" Then
n = n + 1
Else
If Dic.Exists(s) Then
Else
If i > 2 Then
Dic(s2) = Dic(s2) & "," & n
End If
Dic.Add s, i
s2 = s
cnt = cnt + 1
ReDim Preserve Ar(1 To 5, 1 To cnt)
For c = 0 To UBound(vC)
Ar(c + 1, cnt) = vDB(i, vC(c))
Next c
End If
n = 0
End If
Next i
Dic(s2) = Dic(s2) & "," & n
' Records information about the data in a dictionary.
' Dic is "phase neme" is Key, Item is "2,4"
' example for KICkOFF
' dic key is "KICKOFF", Item is "5,4"
' 5 is KICOFF's row number in array vDB
' 4 is the number of blank cells related to kickoff.
With ScheduleForm.SchMainTasklt
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
'.List = Ar
.Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column.
End With
End Sub
Form Code
Private Sub UserForm_Initialize()
Call test
End Sub
Private Sub SchMainTasklt_Click()
Dim s As String, sItem As String
Dim arr As Variant, vC As Variant
Dim vR() As Variant
Dim st As Long, ed As Long
Dim iLast As Long, iFirst As Long
Dim i As Long, n As Integer
Dim j As Integer
vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F
s = SchMainTasklt.Value
'MsgBox s
sItem = Dic(s)
arr = Split(sItem, ",")
st = Val(arr(0))
ed = Val(arr(1))
iFirst = st + 1
iLast = st + ed
If ed = 0 Then
MsgBox "no data!!"
Exit Sub
End If
For i = iFirst To iLast
n = n + 1
ReDim Preserve vR(1 To 5, 1 To n)
For j = 0 To UBound(vC)
vR(j + 1, n) = vDB(i, vC(j))
Next j
Next i
With ListBox2
.ColumnCount = 5
.ColumnWidths = "50;150;50;60;60"
.BoundColumn = 2
.Column = vR
End With
End Sub
Result Image
When you click the "KICKOFF" , Show kickoff related data in listbox2.
Problem :
Code returns 0 matches.
Code :
Sub searchNames()
Dim loc As String
Call location(loc)
Dim loadWb As Workbook
Dim loadWs As Worksheet
' ~~ Load file location
Set loadWb = Workbooks.Open(loc)
Set loadWs = loadWb.Sheets("Sheet1")
' ~~ Init rows in loaded excel
Dim lrow As Long
With loadWs
' ~~ Set range for lookup value
lrow = .Range("G" & .rows.Count).End(xlUp).Row
End With
' ~~ Loop to remove trailing spaces
Dim TrimCounter As String
Dim NewString As String
For ind = 2 To lrow
' ~~ Set rows for trim
TrimCounter = loadWs.Range("G" & ind).Value
NewString = Trim(TrimCounter)
' ~ Write trimmed values
loadWs.Range("G" & ind).Value = NewString
Next ind
' ~~ Set output worksheet
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("ALL BRANDS")
Dim lrowWs As Long
With ws
lrowWs = .Range("D" & .rows.Count).End(xlUp).Row
End With
Dim counter As Long
Dim rows As Long
Dim nameCounter As String
counter = 0
' ~~ Get controlPointNumber in ALL BRANDS
For ind = 2 To lrowWs
' ~~ Set controlPointNumber
nameCounter = ws.Range("D" & ind).Value
' ~~ Start with row 2 in loaded Excel to omit header
For ind2 = 2 To lrow
' ~~ Check if the name matches in ALL BRANDS
If loadWs.Range("G" & ind2).Value = nameCounter Then
counter = counter + 1
End If
Next ind2
' ~~ Write the value in Worksheet 'ALL BRANDS' equal to the results
ws.Range("L" & ind).Value = counter
' ~~ Init counter to 0 and check other controlPointNumber
counter = 0
rows = rows + 1
Next ind
' ~~ Close workbook ~ Byeee
loadWb.Close False
MsgBox "Scan finished! Scanned " & rows & " rows"
End Sub
Screenshots :
Am I missing something? Any ideas?
EDIT:
Problem located. There are spaces in the values in COLUMN G
Change the part of the code like this:
For ind = 2 To lrowWs
Debug.Print lrowWs
nameCounter = ws.Range("D" & ind).value
Debug.Print nameCounter
For ind2 = 2 To lrow
If loadWs.Range("G" & ind2).value = nameCounter Then
Debug.Print loadWs.Range("G" & ind2).value
counter = counter + 1
End If
Next ind2
ws.Range("L" & ind).value = counter
Stop
counter = 0
rows = rows + 1
Next ind
Then, when you reach the stop, you should have 3 different values in the immediate window. Take a good look at them, analyze them and repair the whole code correspondingly.
Edit:
Probably the error comes from the idea, that you can use something like this:
Dim rows As Long
Thus, VBA does not know what you mean, when you say rows.Count. Long story short, change the Dim rows as Long to Dim lngRows as long and fix correspondingly everywhere.
I always worked with the .find Method. For me it's easier and if you combined it with a dictionary you can do the whole range and can be sure that no Value will be missing. The code will take the range with values from column A and will count how often the value appears in the range. Hope the code can help you.
Sub Makro1()
'Excel objects.
Dim wb As Workbook
Dim ws As Worksheet
Dim rngLockin As Range
Dim rngFind As Range
Dim idx As Integer
Dim idxRow As Integer
idxRow = 2
Dim strAddress As String
'Initialize the Excel objects.
Set wb = ThisWorkbook
Set ws = wb.Worksheets("Tabelle1")
Set dicSearch = CreateObject("Scripting.Dictionary")
LastRow = ws.UsedRange.Rows.Count
Set rngLockin = ws.Range("A2:A22").SpecialCells(xlCellTypeConstants)
For Each rngcell In rngLockin
'I Value is not in dic, insert it and start counting
If Not dicSearch.Exists(rngcell.Value) Then
dicSearch.Add rngcell.Value, ""
'Search the four columns for any constants.
'Retrieve all columns that contain X. If there is at least one, begin the DO/WHILE loop.
idx = 0
With rngLockin
Set rngFind = .Find(What:=rngcell.Value, LookIn:=xlValues)
If Not rngFind Is Nothing Then
strAddress = rngFind.Address
idx = idx + 1
rngFind.Select
'Unhide the column, and then find the next X.
Do
rngFind.EntireColumn.Hidden = False
Set rngFind = .FindNext(rngFind)
rngFind.Select
If Not rngFind Is Nothing And rngFind.Address <> strAddress Then idx = idx + 1
Loop While Not rngFind Is Nothing And rngFind.Address <> strAddress
End If
End With
Cells(idxRow, 3) = rngcell.Value
Cells(idxRow, 4).Value = idx
idxRow = idxRow + 1
End If
Next
End Sub
Fell free to ask if you have a question.
I have a description in Column A which contains some error code like ESFB-1 , ESFB-11 etc... with list of error codes in sheet2 a total of about 36 error codes
I have the below code written & works but the only problem is it is treating both ESFB-1 & ESFB-11 as same the list has about 35 error codes with similar nomenclature below is the code
enter code here
Sub sear()
Dim rng As Range
Dim str As String
Dim str1 As String
Dim val1 As Long
Dim val2 As Long
Dim col As Integer
Dim col2 As Integer
Dim row2 As Integer
Dim row As Integer
Dim var As Integer
Dim lastRow As Long
Dim lastrow1 As Long
Dim pos As Integer
lastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).row
lastrow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row
var = 0
col = 1
row = 2
row2 = 2
pos = 0
Do While var <> 1
Do While row <= lastrow1
Do While pos = 0
str = Sheets("Sheet1").Cells(row, 1).Value
str1 = Sheets("Sheet2").Cells(row2, 1).Value
pos = InStrRev(str, str1, vbTextCompare)
row2 = row2 + 1
If row2 = lastRow Then Exit Do
Loop
If pos <> 0 Then
Cells(row, 7).Value = Sheets("Sheet2").Cells(row2 - 1, 1)
End If
Cells(row, 8).Value = pos & Sheets("Sheet1").Cells(row, 1)
pos = 0
row2 = 2
row = row + 1
Loop
var = 1
Loop
End Sub
Please suggest modifications which can help me find the exact error code from description
Instr will give you false positive like you are getting for ESFB-1 & ESFB-11 and hence you need a more robust check.
Is this what you are trying?
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lRow As Long
Dim Arws As Variant, tempAr As Variant
Dim rng As Range, aCell As Range
'~~> Set your sheets here
Set ws1 = Sheet1: Set ws2 = Sheet2
With ws2
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> Store the error codes in an array
Arws = .Range("A1:A" & lRow)
End With
With ws1
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> This is your range from 1st sheet
Set rng = .Range("A2:A" & lRow)
'~~> Loop through all cells and split it's contents
For Each aCell In rng
tempAr = Split(aCell.Value)
'~~> Loop through each split word in the array
For i = LBound(tempAr) To UBound(tempAr)
'~~> Check if exists in array
If ExistsInArray(Trim(tempAr(i)), Arws) Then
'~~> If it does then write to col B
aCell.Offset(, 1).Value = Trim(tempAr(i))
Exit For
End If
Next i
Next aCell
End With
End Sub
'~~> Function to check if a string is int he array
Function ExistsInArray(s As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
ExistsInArray = Application.Match(s, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
ExistsInArray = Application.Match(s, Application.Index(arr, , i), 0)
On Error GoTo 0
If ExistsInArray = True Then Exit For
Next
End Select
End Function
Screenshot
I am assigning numbers their order in which they appear in the list and i do that using countif function in excel something like this,
=COUNTIF(A$2:A2,A2)
Number Count
10 1
10 2
10 3
11 1
11 2
11 3
12 1
I wish to achieve the same using VBA. However, here are the specifics.
I want to take a variable and compute the countif function and then loop them through.
Once the variable has all numbers(array) I want to paste them in a location.
Assuming column A is sorted as per your list above you could use the following.
Dim arr(100,1) as double '100 = arbitrary number for this example
dim n as double
n=1
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
For roW = 1 to 100
IF Cell(roW + 2, 1).value = Cell(roW + 1, 1).value Then
n = Cell(roW + 2, 1).value
Else
n=1
End if
arr(roW,0) = Cell(roW + 2, 1).value
arr(roW,1) = n
Next
Range("C2:D102")=arr
And another option,
Sub GetUniqueAndCountif()
Dim cUnique As Collection
Dim Rng As Range
Dim Cell As Range, nW As Range
Dim sh As Worksheet
Dim vNum As Variant
Set sh = ThisWorkbook.Sheets("Sheet1")
Set Rng = sh.Range("A2", sh.Range("A2").End(xlDown))
Set cUnique = New Collection
On Error Resume Next
For Each Cell In Rng.Cells
cUnique.Add Cell.Value, CStr(Cell.Value)
Next Cell
On Error GoTo 0
For Each vNum In cUnique
Set nW = Cells(Rows.Count, "C").End(xlUp).Offset(1, 0)
nW = vNum
nW.Offset(, 1) = WorksheetFunction.CountIf(Rng, nW)
Next vNum
End Sub
The following code evaluates the results as a single array formula and assigns this to a varaiable v. You can adapt references and add variable declarations as needed.
Sub CountifArray()
v = Evaluate(Replace("INDEX(COUNTIF(OFFSET(y,,,ROW(y)-MIN(ROW(y))+1),y),)", "y", "A2:A8"))
Range("B2:B8") = v
End Sub
This is my suggestion.
Sub Counts()
Dim ws As Worksheet
Set ws = ThisWorkbook.ActiveSheet
Dim lngLastRow As Long
lngLastRow = ws.UsedRange.Rows.Count
Dim Arr() As Variant
'Taking values in column A into an array
Arr = ws.Range("A2:A" & lngLastRow).Value
Dim Arr2() As Variant
'another Array for Countif results
ReDim Arr2(lngLastRow - 2, 0)
Dim count As Long
Dim i As Long, j As Long 'counters
'counting
For i = LBound(Arr) To UBound(Arr)
count = 0
For j = LBound(Arr) To i
If Arr(j, 1) = Arr(i, 1) Then count = count + 1
Next
'filling the array with results
Arr2(i - 1, 0) = count
Next
'sending results back to the worksheet
ws.Range("B2:B" & lngLastRow).Value = Arr2
Set ws = Nothing
End Sub
I have a slight problem in Excel. I need to sync up the values in the curly braces {} found in column C and put them against the user id in column F. I would like this data to be copied across to a new worksheet in the same workbook. Any ideas how I could accomplish this? You don't have to provide any code but a nudge in the right direction would be great.
E.g. on the Emails sheet
becomes this on a new sheet
In case anyone needs help, this is the solution:
Sub CopyConditional()
Dim wshS As Worksheet
Dim WhichName As String
Set wshS = ActiveWorkbook.Sheets("Emails")
WhichName = "NewSheet"
Const NameCol = "C"
Const FirstRow = 1
Dim LastRow As Long
Dim SrcRow As Long
Dim TrgRow As Long
Dim wshT As Worksheet
Dim cpt As String
Dim user As String
Dim computers() As String
Dim computer As String
On Error Resume Next
Set wshT = Worksheets(WhichName)
If wshT Is Nothing Then
Set wshT = Worksheets.Add(After:=wshS)
wshT.Name = WhichName
End If
On Error GoTo 0
If wshT.Cells(1, NameCol).value = "" Then
TrgRow = 1
Else
TrgRow = wshT.Cells(wshT.Rows.Count, NameCol).End(xlUp).Row + 1
End If
LastRow = wshS.Cells(wshS.Rows.Count, NameCol).End(xlUp).Row
For SrcRow = FirstRow To LastRow
cpt = wshS.Range("C" & SrcRow).value
user = wshS.Range("F" & SrcRow).value
If InStr(cpt, ":") Then
cpt = Mid(cpt, InStr(1, cpt, ":") + 1, Len(cpt))
End If
If InStr(cpt, ";") Then
computers = Split(cpt, ";")
For i = 0 To UBound(computers)
If computers(i) <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computers(i), Len(computers(i)) - 1), 2)
TrgRow = TrgRow + 1
End If
Next
Else
computer = cpt
If computer <> "" Then
wshT.Range("A" & TrgRow).value = user
wshT.Range("B" & TrgRow).value = Mid(Left(computer, Len(computer) - 1), 2)
TrgRow = TrgRow + 1
End If
End If
Next SrcRow
End Sub
You didn't ask a question. Basically what you would do is
loop through the values in column F
for each value, get the value in column C
loop through all braced values in column C
let braceValue = parse column C searching for {value}
create a row in new worksheet with column F value, braceValue