The script is doing exactly what I need it to do, but it's inserting the input range (A7:B30) into a single row, rather than the existing format.
Sub UpdateLogWorksheet()
'http://www.contextures.com/xlForm02.html
Dim dataWks As Worksheet
Dim inputWks As Worksheet
Dim nextRow As Long
Dim oCol As Long
Dim myRng As Range
Dim myCopy As String
Dim myCell As Range
'cells to copy from Input sheet - some contain formulas
myCopy = "A7:B30"
Set inputWks = Worksheets("Input")
Set dataWks = Worksheets("Data")
With dataWks
nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
End With
With inputWks
Set myRng = .Range(myCopy)
End With
With dataWks
With .Cells(nextRow, "A")
.Value = ""
.NumberFormat = "dd/mm/yyyy"
End With
.Cells(nextRow, "D").Value = "HELLO"
oCol = 3
For Each myCell In myRng.Cells
dataWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
End With
'clear input cells that contain constants
With inputWks
On Error Resume Next
With .Range(myCopy).Cells.SpecialCells(xlCellTypeConstants)
.ClearContents
Application.GoTo .Cells(1) ', Scroll:=True
End With
On Error GoTo 0
End With
End Sub
Any ideas?
Try changing:
For Each myCell In myRng.Cells
dataWks.Cells(nextRow, oCol).Value = myCell.Value
oCol = oCol + 1
Next myCell
to
For Each myCell In myRng.Cells
dataWks.Range(myCell.Address).Value = myCell.Value
Next myCell
That will preserve the layout, i.e. the data will be pasted into the same range it was copied from.
Related
I want to create a macro that goes through each row in my sheet and checks columns F:I if they have values in them.
If ALL columns are empty then the current row should be deleted.
I tried recycling some code but when I run it, all rows in that sheet get deleted for some reason.
This is the code I have so far:
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim noValues As Range, MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
On Error Resume Next
Set noValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
End If
Next RowToTest
End Sub
You can do this way (it is more efficient to delete rows all in one go using Union):
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet name
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)) '<== Column C cells to loop over from row 2 to last row
If Application.WorksheetFunction.CountBlank(rng.Offset(, 3).Resize(1, 4)) = 4 Then 'rng.Offset(, 3).Resize(1, 4)) limits to column F:I. CountBlank function will return number of blanks. If 4 then all F:I columns in that row are blank
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng) 'gather qualifying ranges into union range object
Else
Set unionRng = rng
End If
End If
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete '<== Delete union range object if contains items
Application.ScreenUpdating = True
End Sub
Or this way:
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)).Offset(, 3).Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 1, 4).Rows
On Error GoTo NextLine
If rng.SpecialCells(xlCellTypeBlanks).Count = 4 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng)
Else
Set unionRng = rng
End If
End If
NextLine:
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Try using WorksheetFunction.CountA.
Option Explicit
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
If WorksheetFunction.CountA(MyRange) = 0 Then
MyRange.EntireRow.Delete
End If
Next RowToTest
End Sub
Try the following:
On Error Resume Next
Set noValues = Intersect(myRange.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
Else
Set noValues = Nothing
End If
I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub
Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub
I need a VBA code that can select common columns from different worksheet and paste the same in the summary sheet.
For example, consider am having 3 sheets in a work book.
Sheet1 has column IP,Tag,Host,service
Sheet2 has column IP,Tag,REASON,source
Sheet3 has column IP,Tag,protocol,port.
I need to fetch the common columns(IP,Tag) in a summary sheet one after another.
Can anyone please help me on this.
Note: The Common columns will not be always in the same (A and B cell range) it may vary as of reports.
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
If myInSht.Name = "PrjA" Or myInSht.Name = "PrjB" Or myInSht.Name = "PrjC" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Consolidated").Range("A:A")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Consolidated").Range("B:B")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Consolidated").Range("C:C")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Consolidated").Range("D:D")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Consolidated").Range("E:E")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count - 1, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
Try this.
Sub Consolidate()
Dim FindCol As String
L1 = Sheets(1).Range("XFD2").End(xlToLeft).Column
FindCol = InputBox("Type in header of Column to be searched")
For k = 2 To Sheets.Count
Sheets(k).Select
l = Range("XFD1").End(xlToLeft).Column
For i = 1 To l
x = Range("A65536").End(xlUp).Row
If Cells(1, i).Value = FindCol Then
Range(Cells(1, i), Cells(x, i)).Copy
Sheets(1).Activate
L2 = Range("XFD1").End(xlToLeft).Column
Sheets(1).Cells(1, L2 + 1).Select
ActiveSheet.Paste
End If
Next
Next
Sheets(1).Activate
End Sub
a somewhat general approach could be the following:
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sheetName As Variant, sharedColumn As Variant
Dim summarySheet As Worksheet
sheetsNames = Array("PrjA", "PrjB", "PrjC") '<--| list your sheets names
If FindSharedColumns(sheetsNames, sharedColumns) Then '<--| if any shared columns between ALL listed sheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sheetName In sheetsNames '<--| loop through sheets ALL sharing the same columns
With Worksheets(sheetName) '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sheetsNames As Variant, sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sheetName In sheetsNames
If GetSheet(sheetName, sht) Then
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
End If
Next
For Each key In .keys
If .Item(key) < UBound(sheetsNames) + 1 Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function
if sheets names differs every time then you have to loop through all worksheets
the changes in the above code are minimal, here's the complete code
Option Explicit
Sub Collect()
Dim sheetsNames As Variant, sharedColumns As Variant
Dim sht As Worksheet, sharedColumn As Variant
Dim summarySheet As Worksheet
If FindSharedColumns(sharedColumns) Then '<--| if any shared columns between ALL worksheets
Set summarySheet = GetOrCreateSheet("Consolidated") '<--| set or create "Consolidated" sheet: if already there it'll be cleared
With summarySheet
.Range("A1").Resize(, UBound(sharedColumns) + 1).Value = sharedColumns '<--| write headers as the names found in first cell of "shared" columns
End With
For Each sht In Worksheets '<--| loop through all worksheets
With sht '<--| reference current sheet in loop
For Each sharedColumn In sharedColumns '<--| loop through shared columns names
With .Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).EntireColumn '<--| reference column corresponding to current shared column in current sheet
With .Resize(WorksheetFunction.CountA(.cells) - 1).Offset(1) '<--| reference its cells from row 2 down to last not empty one (WARNING: it's assumed there are not blank cells in between)
summarySheet.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues).Find(what:=sharedColumn, LookIn:=xlValues, lookat:=xlWhole).End(xlDown).End(xlDown).End(xlUp).Offset(1).Resize(.Rows.Count).Value = .Value '<--| update 'summarySheet' appending current values at the bottom of its corresponding column
End With
End With
Next
End With
Next
End If
End Sub
Function GetOrCreateSheet(shtName As String) As Worksheet
If Not GetSheet(shtName, GetOrCreateSheet) Then
Set GetOrCreateSheet = Worksheets.Add(after:=Worksheets(Worksheets.Count))
GetOrCreateSheet.Name = shtName
Else
GetOrCreateSheet.UsedRange.ClearContents
End If
End Function
Function GetSheet(sheetName As Variant, sht As Worksheet) As Boolean
On Error Resume Next
Set sht = Worksheets(sheetName)
GetSheet = Not sht Is Nothing
End Function
Function FindSharedColumns(sharedColumns As Variant) As Boolean
Dim sheetName As Variant
Dim sht As Worksheet
Dim col As Range
Dim key As Variant
With CreateObject("Scripting.Dictionary")
For Each sht In Worksheets
For Each col In sht.Rows(1).SpecialCells(xlCellTypeConstants, xlTextValues)
.Item(col.Value) = .Item(col.Value) + 1
Next
Next
For Each key In .keys
If .Item(key) < Worksheets.Count Then .Remove key
Next
If .Count > 0 Then
sharedColumns = .keys
FindSharedColumns = True
End If
End With
End Function
The below code works well the requirement
Sub Collect()
Dim myInSht As Worksheet
Dim myOutSht As Worksheet
Dim aRow As Range
Dim aCol As Range
Dim myInCol As Range
Dim myOutCol As Range
Dim calcState As Long
Dim scrUpdateState As Long
Dim cell As Range
Dim iLoop As Long, jLoop As Long
jLoop = 2
' loop through the worksheets
For Each myInSht In ActiveWorkbook.Worksheets
' pick only the worksheets of interest
'If myInSht.Name = "a" Or myInSht.Name = "aa" Or myInSht.Name = "aaa" Then
' find the columns of interest in the worksheet
For Each aCol In myInSht.UsedRange.Columns
Set myOutCol = Nothing
If aCol.Cells(1, 1).Value = "timestamp" Then Set myOutCol = Sheets("Summary").Range("B2:B1000")
If aCol.Cells(1, 1).Value = "ip" Then Set myOutCol = Sheets("Summary").Range("C2:C1000")
If aCol.Cells(1, 1).Value = "protocol" Then Set myOutCol = Sheets("Summary").Range("D2:D1000")
If aCol.Cells(1, 1).Value = "port" Then Set myOutCol = Sheets("Summary").Range("E2:E1000")
If aCol.Cells(1, 1).Value = "hostname" Then Set myOutCol = Sheets("Summary").Range("F2:F1000")
If aCol.Cells(1, 1).Value = "tag" Then Set myOutCol = Sheets("Summary").Range("G2:G1000")
If aCol.Cells(1, 1).Value = "asn" Then Set myOutCol = Sheets("Summary").Range("I2:I1000")
If aCol.Cells(1, 1).Value = "geo" Then Set myOutCol = Sheets("Summary").Range("J2:J1000")
If aCol.Cells(1, 1).Value = "region" Then Set myOutCol = Sheets("Summary").Range("K2:K1000")
If aCol.Cells(1, 1).Value = "naics" Then Set myOutCol = Sheets("Summary").Range("L2:L1000")
If aCol.Cells(1, 1).Value = "sic" Then Set myOutCol = Sheets("Summary").Range("M2:M1000")
If aCol.Cells(1, 1).Value = "server_name" Then Set myOutCol = Sheets("Summary").Range("H2:H1000")
If Not myOutCol Is Nothing Then
' don't move the top line, it contains the headers - no data
Set myInCol = aCol
Set myInCol = myInCol.Offset(1, 0).Resize(myInCol.Rows.Count, myInCol.Columns.Count)
' transfer data from the project tab to the consolidated tab
iLoop = jLoop
For Each aRow In myInCol.Rows
myOutCol.Cells(iLoop, 1).Value = aRow.Cells(1, 1).Value
iLoop = iLoop + 1
Next aRow
End If
Next aCol
'End If
If iLoop > jLoop Then jLoop = iLoop
Next myInSht
End Sub
I have created macro that works like a vlookup but has split values. I would like to find value from second sheet of split values (separated by semicolon ) and copy and paste the description to new sheet.
The first loop goes through the list in sheet 2 and sets the value in a variable, the second loop through split values checks when there is exact match and the description is copied and pasted to the second sheet.
However - it doesn't work and I don't know what the problem is.
I have notification "type mismatch".
I tried vlookup with part text string but it doesn't work either.
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr = variable Then
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
Next i
Else
Worksheets("sheet2").bCell(, 2).PasteSpecial xlPasteValues
End If
End If
Next
End If
Next
End With
End Sub
I changed my code but it is still not work properly, I have a result:
try this
Sub test()
Dim Cl As Range, Key As Variant
Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary")
Dic.CompareMode = vbTextCompare
With Sheets("Sheet1")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
If Cl.Value <> "" Then
Dic.Add Cl.Row & "|" & Replace(LCase(Cl.Value), ";", "||") & "|", Cl.Offset(, 1).Text
End If
Next Cl
End With
With Sheets("Sheet2")
For Each Cl In .Range("A1:A" & .Cells.SpecialCells(xlCellTypeLastCell).Row)
For Each Key In Dic
If Key Like "*|" & LCase(Cl.Value) & "|*" And Cl.Value <> "" Then
Cl.Offset(, 1).Value = Dic(Key)
Exit For
End If
Next Key
Next Cl
End With
End Sub
Output Result
Sub YourVLookup()
Dim rng As Variant, rng2 As Variant
Dim lastRow As Long, i As Long, j As Long, k As Long
Dim aCell As Variant, bCell As Variant
Dim myAr() As String, variable As String
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow)
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Set rng2 = ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow)
For i = LBound(rng2, 1) To UBound(rng2, 1)
If Len(Trim(rng2(i, 1))) <> 0 Then
variable = rng2(i, 1)
For j = LBound(rng, 1) To UBound(rng, 1)
If Len(Trim(rng(j, 1))) <> 0 Then
If InStr(1, rng(j, 1), ";") > 0 Then
myAr = Split(rng(j, 1))
For k = LBound(myAr) To UBound(myAr)
If myAr(k) = variable Then
rng2(i, 2) = myAr(k)
End If
Next k
ElseIf rng(j, 1) = rng2(i, 1) Then
rng2(i, 2) = rng(j, 2)
End If
End if
Next j
End If
Next i
lastRow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet1").Range("A1:B"&lastRow) = rng
lastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
ThisWorkbook.Worksheets("Sheet2").Range("A1:B"&lastRow) = rng2
End Sub
You were pasting something that you don't have copied already, you forgot to close a With, and you can't use bCell(,2), so
Try this :
Sub Metadane()
Dim ws As Worksheet
Dim aCell As Range, rng As Range
Dim Lrow As Long, i As Long
Dim myAr() As String
Dim ws2 As Worksheet
Dim bCell As Range, rng2 As Range
Dim variable As String
'~~> Change this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("A1:A" & Lrow)
End With
Set ws2 = ThisWorkbook.Sheets("Sheet2")
With ws2
'~~> Find the last row in Col A
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Set your range
Set rng2 = .Range("A1:A" & Lrow)
'~~> Loop trhough your range
For Each bCell In rng2
If Len(Trim(bCell.Value)) <> 0 Then
variable = bCell.Value
For Each aCell In rng
'~~> Skip the row if value in cell A is blank
If Len(Trim(aCell.Value)) <> 0 Then
'~~> Check if the cell has ";"
'~~> If it has ";" then loop through values
If InStr(1, aCell.Value, ";") Then
myAr = Split(aCell.Value, ";")
For i = LBound(myAr) To UBound(myAr)
If myAr(i) <> variable Then
Else
'You were pasting nothing with that
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
Next i
Else
'Same here
'.bCell(, 2).PasteSpecial xlPasteValues
.Cells(bCell.Row, 2) = aCell.Offset(0, 1).Value
End If
End If
Next aCell
End If
Next bCell
End With
End Sub
Pls help me modify this code but I would like to keep it 90% the same.
I want to delete the rows that does not contain the array items. So my program deletes rows with a, b in cell. How can I modify the below code so that it erases the other a, b to remain in exec.
myArr = Array("a","b")
For I = LBound(myArr) To UBound(myArr)
'Sheet with the data, you can also use Sheets("MySheet")
With ActiveSheet
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Apply the filter
.Range("E1:E" & .Rows.Count).AutoFilter Field:=1, Criteria1:=myArr(I)
Set rng = Nothing
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
Next I
This works for me... I have commented the code so you should not have a problem understanding it...
Option Explicit
Dim myArr
Sub Sample()
Dim ws As Worksheet
Dim Lrow As Long, i As Long
Dim rRange As Range, delRange As Range
myArr = Array("a", "b", "c")
Set ws = ThisWorkbook.Sheets("MySheet")
With ws
'~~> Get last row of Sheet
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
If Not DoesExists(.Range("A" & i).Value) Then
If delRange Is Nothing Then
Set delRange = .Range("A" & i)
Else
Set delRange = Union(delRange, .Range("A" & i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.EntireRow.Delete
End With
End Sub
Function DoesExists(clVal As Variant) As Boolean
Dim j As Long
For j = LBound(myArr) To UBound(myArr)
If clVal = myArr(j) Then
DoesExists = True: Exit For
End If
Next j
End Function