I have VBA code written up to find and replace question marks in all worksheets in a workbook. However it is not working, can anyone help me out to see where did i go wrong?
Sub ReplaceQM()
Dim lRow As Long
Dim lCol As Long
totalSheet = ThisWorkbook.Sheets.Count
MsgBox totalSheet
For x = 1 To totalSheet
lRow = ThisWorkbook.Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row
lCol = ThisWorkbook.Sheets(x).Cells(1, Columns.Count).End(xlToLeft).Column
For Z = 1 To lRow
For i = 1 To lCol
getPos = InStr(1, ThisWorkbook.Sheets(x).Cells(Z, i).Value, "~?")
If getPos > 0 Then
ThisWorkbook.Sheets(x).Cells(Z, i).Value = Replace(ThisWorkbook.Sheets(x).Cells(Z, i).Value, "~?", " ")
End If
Next i
Next Z
Next x
End Sub
You're better off using Excel's in-range replace function:
For Each ws In ThisWorkbook
ws.UsedRange.Cells.Replace what:="~?", Replacement:=" ", LookAt:=False, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
Next ws
Related
I have this Macro which essentially uses two sheets - sheet2 updates sheet1 and then kills the second worksheet.
I noticed that when it comes to one part of the macro (delete row which has "Delete" in column A in worksheet 1) it doesn't appear to work if I run the Macro from worksheet 2. If I run it from Sheet 1 is works without a problem.
This is the full code, just in case you need to look at it - I'll highlight the part that I'm having trouble with next.:
Public Sub Cable_Load_full()
'~~> Copy New Accounts from worksheet2
Dim ws1 As Worksheet, ws2 As Worksheet
Dim bottomL As Integer
Dim x As Integer
Dim c As Range
Dim i As Long, J As Long, LastCol As Long
Dim ws1LR As Long, ws2LR As Long
Dim ws1Rng As Range, aCell As Range
Dim SearchString
Set ws1 = Sheets("CableSocials")
Set ws2 = Sheets("CableRevised")
bottomL = ws2.Range("A" & Rows.Count).End(xlUp).Row: x = 1
x = ws1.Range("A" & Rows.Count).End(xlUp).Row
x = x + 1
For Each c In ws2.Range("A1:A" & bottomL)
If c.Value = "New" Then
c.EntireRow.Copy ws1.Range("A" & x)
x = x + 1
End If
Next c
'~~> Assuming that ID is in Col B
'~~> Get last row in Col B in Sheet1
ws1LR = ws1.Range("B" & Rows.Count).End(xlUp).Row
'~~> Set the Search Range
Set ws1Rng = ws1.Range("B1:B" & ws1LR)
'~~> Adding Revise Column to worksheet 1
ws1.Columns("A:A").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Value = "Revise"
Set ws2 = Sheets("CableRevised")
'~~> Turn off Filter
ws2.AutoFilterMode = False
'~~> Get last row in Col A in Sheet2
ws2LR = ws2.Range("B" & Rows.Count).End(xlUp).Row
'~~> Loop through the range in Sheet 2 to match it with the range in Sheet1
For i = 1 To ws2LR
SearchString = ws2.Range("B" & i).Value
'~~> Search for the ID
Set aCell = ws1Rng.Find(What:=SearchString, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
'~~> If found
If Not aCell Is Nothing Then
'~~> Append values
ws1.Cells(aCell.Row, 1).Value = ws2.Cells(i, 1).Value
ws1.Cells(aCell.Row, 3).Value = ws2.Cells(i, 2).Value
ws1.Cells(aCell.Row, 19).Value = ws2.Cells(i, 18).Value
ws1.Cells(aCell.Row, 20).Value = ws2.Cells(i, 19).Value
End If
Next i
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
'~~> Removing New from Column B
ws1.Columns("B").Replace What:="New", _
Replacement:="", _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
MatchCase:=False, _
SearchFormat:=False, _
ReplaceFormat:=False
ws1.Columns("A").EntireColumn.Delete
Call SheetKiller
End Sub
Sub SheetKiller()
Dim s As Worksheet, t As String
Dim i As Long, K As Long
K = Sheets.Count
For i = K To 1 Step -1
t = Sheets(i).Name
If t = "CableRevised" Then
Application.DisplayAlerts = False
Sheets(i).Delete
Application.DisplayAlerts = True
End If
Next i
End Sub
So the part that only works when I run the Macro from Sheet1 is:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With Range("A1", Range("A" & Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
I'm not sure why - is it acting as if it will only delete the rows from the ActiveSheet (which I guess would be the Sheet I run the Macro from?) ? Is it possible to make it work even if I run the Macro from Sheet2?
Thanks for any help you provide!
You need to explicitly refer to ranges on ws1. As written, your code is looking for ranges on the active sheet.
Try this:
'~~> Delete the accounts that need to be deleted
ws1.AutoFilterMode = False
With ws1.Range("A1", ws1.Range("A" & ws1.Rows.Count).End(xlUp))
.AutoFilter 1, "Delete"
On Error Resume Next
.Offset(1).SpecialCells(12).EntireRow.Delete
End With
ws1.AutoFilterMode = False
some time ago I posted a similar question here and got a great answer. But now I would need a slightly altered code but I am not able to change it up.
In an Excel sheet I have cells which have values but all cells between those two are empty. I want Excel to fill the empty cells between them with the values of a third cell. To visualise:
That's what it looks like
Now I want the macro to fill out all the empty cells with the value of the corresponding J cell. So it would look like this:
From the previous thread I used this code:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Is it possible to change up the existing code? Or maybe the other code from my previous, linked question? I looked into both but I myself unfortunately wasn't able.
Any help is appreciated. Thanks in advance.
Use the code from the your other question but change rowval to look at column J
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, 10).Value --This is all I changed
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
Answer with modifying previous code
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = Cells(.Areas(1).Row, "J").Value
End With
Next
End Sub
Assuming you have three values in each row and they are not consecutive, a small change to your original code should suffice.
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1).Offset(, 1), .Areas(2).Offset(, -1)).Value = .Areas(3).Value
End With
Next
End Sub
This will do exactly what you want in three lines
Sub FillBlanks()
Dim c
For Each c In ActiveSheet.UsedRange.Columns("J").SpecialCells(xlCellTypeConstants)
Range(c.Offset(0, c.End(xlToLeft).Column - c.Column), c.Offset(0, -c.Column + 1)).SpecialCells(xlCellTypeBlanks).Value2 = c.Value2
Next c
End Sub
I am currently trying to write some VBA code which will fill out all cells between two cells with the value of the two cells.
Here is what I have :
And I would like the code to fill out all cells in between like this:
So, as you can see I would like all the cells in between to be filled out with the same value as the two corner cells.
Any help is very much appreciated! Thanks in advance.
you could use SpecialCells() method of Range object:
Sub main()
Dim cell As Range
For Each cell In Intersect(Columns(1), ActiveSheet.UsedRange.SpecialCells(xlCellTypeConstants).EntireRow)
With cell.EntireRow.SpecialCells(xlCellTypeConstants)
Range(.Areas(1), .Areas(2)).Value = .Areas(1).Value
End With
Next
End Sub
Place this in a new module and run test_DTodor:
Option Explicit
Sub test_DTodor()
Dim wS As Worksheet
Dim LastRow As Double
Dim LastCol As Double
Dim i As Double
Dim j As Double
Dim k As Double
Dim RowVal As String
Set wS = ThisWorkbook.Sheets("Sheet1")
LastRow = LastRow_1(wS)
LastCol = LastCol_1(wS)
For i = 1 To LastRow
For j = 1 To LastCol
With wS
If .Cells(i, j) <> vbNullString Then
'1st value of the row found
RowVal = .Cells(i, j).Value
k = 1
'Fill until next value of that row
Do While j + k <= LastCol And .Cells(i, j + k) = vbNullString
.Cells(i, j + k).Value = RowVal
k = k + 1
Loop
'Go to next row
Exit For
Else
End If
End With 'wS
Next j
Next i
End Sub
Public Function LastCol_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastCol_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
Else
LastCol_1 = 1
End If
End With
End Function
Public Function LastRow_1(wS As Worksheet) As Double
With wS
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow_1 = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow_1 = 1
End If
End With
End Function
I'm doing this code for the company where I work as a internship. I did some part of it with the help of people from this forum and others but the code is big and I cannot find a place or the piece of code needed to do what I asked for, and that fits my code I'm newbie by the way.
So I will explain the code IT will import from a target excel file and then paste in my main file, after that it will search in the main file for the data that is present in the column A and then copy the information that is linked to the names and paste it in the import sheet called (Status) so I wanted to put a delete duplications before searching the information in the main file.
Sorry for the Big code. Forgot to mentioned the files come duplicated from the source file but I cannot change the source file, probably is easier if the import doesn't take duplicated rows ?
Sub ImportData()
Application.ScreenUpdating = False
Dim Path As String, Lstrw As Long
Dim SourceWb As Workbook
Dim TargetWb As Workbook
Path = "C:\Users\DZPH8SH\Desktop\Status 496 800 semana 12 2015.xls" 'Change this to your company workbook path
workbook path
Set SourceWb = Workbooks.Open(Path)
Set TargetWb = ThisWorkbook
Dim n As Integer, targetRow As Long
targetRow = 3
With SourceWb.Sheets(1)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Range("M1:M" & Lstrw).AutoFilter Field:=1, Criteria1:="496"
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
.ShowAllData
End With
With SourceWb.Sheets(2)
Lstrw = .Cells.Find(What:="*", SearchOrder:=xlRows, SearchDirection:=xlPrevious, LookIn:=xlValues).Row
.Application.Union(.Range("D2:D" & Lstrw), .Range("F2:F" & Lstrw), .Range("I2:I" & Lstrw), .Range("M2:M" & Lstrw)).Copy
TargetWb.Sheets(7).Cells(TargetWb.Sheets(7).Rows.Count, "A").End(xlUp)(2).PasteSpecial xlPasteValues
End With
SourceWb.Close savechanges:=False
Application.ScreenUpdating = True
'====================================== Search in the main file code below
On Error Resume Next
Dim CurrWk As Worksheet
Dim wb As Workbook
Dim wk As Worksheet
Dim LRow As Integer
Dim myLRow As Integer
Dim myLCol As Integer
Dim F1 As Boolean
Dim f As Boolean
Set wb = ActiveWorkbook
Set CurrWk = wb.Sheets(7)
LRow = LastRow(CurrWk)
For r = 3 To LRow
f = False
For Each wk In wb.Worksheets
If wk.Name = "Status" Or wk.Name = "Gráfico_2015" Then GoTo abc 'Exit For
If wk.Visible = xlSheetHidden Then GoTo abc 'Exit For
myLRow = LastRow(wk)
myLCol = LastCol(wk)
For r1 = 3 To myLRow
For c1 = 1 To myLCol
If Trim(CurrWk.Cells(r, 1).Value) = Trim(wk.Cells(r1, c1).Value) Then
f = True
F1 = False
If wk.Name = "ÄA" Then
For I = 12 To 18
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
Else
For I = 14 To 20
If wk.Cells(r1, I).Value = 1 Then
CurrWk.Cells(r, 6).Value = wk.Cells(2, I).Value
F1 = True
Exit For
End If
Next I
End If
If F1 = False Then CurrWk.Cells(r, 6).Value = "Set de equipa diferente"
End If
Next c1
Next r1
'If f = True Then Exit For
abc:
Next wk
If f = False Then
CurrWk.Cells(r, 12).Value = "Não está presente no ficheiro"
End If
Next r
Set wk = Nothing
Set wb = Nothing
On Error GoTo 0
MsgBox "Finished"
End Sub
Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function
Function LastCol(sh As Worksheet)
On Error Resume Next
LastCol = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Column
On Error GoTo 0
End Function
You could try exploring this avenue...
https://msdn.microsoft.com/en-us/library/office/ff193823.aspx
Using the VBA side of Range.RemoveDuplicates instead of manually just doing Remove Duplicates from the Data ribbon.
My query is if I insert row using a button, it should also add serial numbers to the rows like 1,2,3 etc...
I have the below code here in Sheet1 of the worksheet for adding the serial numbers when I add rows
Private Sub Worksheet_Change1(ByVal Target As Range)
Dim StartNum As Integer
Dim FirstCell As Integer
Dim LastCell As Integer
StartNum = 2
FirstCell = 3
LastCell = 17
Application.EnableEvents = False
Do While FirstCell <= LastCell
Range("B" & FirstCell).Value = StartNum
FirstCell = FirstCell + 1
StartNum = StartNum + 1
Loop
Range("B" & LastCell + 1).Value = ""
Application.EnableEvents = True
End Sub
The below code is written in module1 to insert rows with formula of A1 copied to new rows
Sub Macro2()
Rows("2:2").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("B1:D1").Select
Selection.AutoFill Destination:=Range("B1:D2"), Type:=xlFillDefault
Range("B1:D2").Select
End Sub
Now my Question is how to call the private sub from the Module Macro2 code while inserting rows
Any suggestions, waiting for your replies at the earliest.
Like I mentioned you do not need the Worksheet_Change code for this. Paste the below code in a module and try it..
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
'~~> Set this to the relevant sheet
Set ws = Sheets("Sheet1")
With ws
'~~> Insert at row 2
.Rows(2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'~~> Autofill B1:D1 to C1:D2
.Range("B1:D1").AutoFill Destination:=.Range("B1:D2"), Type:=xlFillDefault
'~~> Find the last row
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
'~~> Renumber the cells in Col B
For i = 1 To lRow
.Range("B" & i).Value = i
Next i
End With
End Sub
FOLLOWUP
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long, j As Double
'~~> Set this to the relevant sheet
Set ws = Sheets("Sheet1")
With ws
'~~> Insert at row 2
.Rows(2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'~~> Autofill B1:D1 to C1:D2
.Range("B1:D1").AutoFill Destination:=.Range("B1:D2"), Type:=xlFillDefault
'~~> Find the last row
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
lRow = .Cells.Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
lRow = 1
End If
'~~> Renumber the cells in Col B 1,1.1,1.2,1.3 etc
j = 1
For i = 1 To lRow
.Range("B" & i).Value = j
j = j + 0.1
Next i
End With
End Sub