I'm using below code in vba but it taking too much time to run. Report have 8 sheets and 450+ rows should be check in each sheet.
Sub forloop()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
lr = Cells(Rows.Count, 3).End(xlUp).Row - 1
For s = 1 To Sheets.Count
For x = lr To 1 Step -1
If Cells(x, 2) <> "" Then
Cells(x, 2).EntireRow.Delete
Next x
Next s
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
End Sub
Could you please suggest me any alternate method to run fast.
dim wb as workbook, sht as worksheet, lr as long, r as long
set wb = workbook.open(wbPathHere)
for each sht in wb.worksheets
lr = sht.cells(sht.rows.count, 3).End(xlUp).row - 1
for r = lr to 1 step-1
if sht.cells(r, 2) <> "" Then sht.cells(r, 2).entirerow.delete
next r
next sht
Related
i had tried this code and return "match" value is work find.
but have a problem such as return "no match" value wrongly.
i think is else part problem did any way to modify this??
thanks!!
Sub compareAndCopy()
Dim lastRowE As Long
Dim lastRowF As Long
Dim lastRowM As Long
Dim lastRowN As Long
Dim foundTrue As Boolean
' stop screen from updating to speed things up
Application.ScreenUpdating = False
lastRowE = Sheets("Sheet2").Cells(Sheets("Sheet2").Rows.Count, "A").End(xlUp).Row
lastRowF = Sheets("Sheet1").Cells(Sheets("Sheet1").Rows.Count, "A").End(xlUp).Row
lastRowM = Sheets("Sheet3").Cells(Sheets("Sheet3").Rows.Count, "B").End(xlUp).Row
lastRowN = Sheets("Sheet4").Cells(Sheets("Sheet4").Rows.Count, "B").End(xlUp).Row
For i = 1 To lastRowE
foundTrue = False
For j = 1 To lastRowF
If Sheets("Sheet2").Cells(i, 1).Value = Sheets("Sheet1").Cells(j, 1).Value Then
lastRowM = lastRowM + 1
Sheets("Sheet2").Rows(i).Copy Destination:= _
Sheets("Sheet3").Rows(lastRowM)
foundTrue = True
Exit For
**else
lastRowN = lastRowN + 1
Sheets("Sheet2").Rows(i).Copy Destination:= _
Sheets("Sheet4").Rows(lastRowN)
foundTrue = True
End If**
Next j
Next i
Application.ScreenUpdating = True
End Sub
Probably faster to use Match() than a nested loop.
Sub compareAndCopy()
Dim sht1 As Worksheet, sht2 As Worksheet
Dim shtDest As Worksheet, i As Long
Set sht1 = Sheets("Sheet1")
Set sht2 = Sheets("Sheet2")
Application.ScreenUpdating = False
For i = 1 To sht2.Cells(sht2.Rows.Count, "A").End(xlUp).Row
Set shtDest = IIf(IsError(Application.Match(sht2.Cells(i, 1).Value, sht1.Columns("A"), 0)), _
Sheets("Sheet4"), Sheets("Sheet3"))
sht2.Rows(i).Copy shtDest.Cells(shtDest.Rows.Count, "B").End(xlUp).Offset(1, -1)
Next i
Application.ScreenUpdating = True
End Sub
I have a 176 worksheets in a workbook, that all have the same format/structure, but are a difference size in row length.
I want to copy the data that is held in range A10:V(X) where X is a calculable number. This data will be pasted underneath each other, in columns B:W of the main sheet "RDBMergeSheet" and the name of the sheet that each row came from will be pasted into Column A of RDBMergeSheet so it can be seen which rows came from which sheets
X = (The lowest used row number in column J) - 3
If it makes it easier, another way to calculate X is find the row number in column A that contains the word "total" and subtract 1 from it.
The following link contains an example of such a sheet, with sanitised data.
https://imgur.com/a/emlZj
The code I've got so far, with help, is:
Sub ImportData()
Dim x As Long
Dim LR As Long
Dim wks As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Sheets("RDBMergeSheet"): If Not wks Is Nothing Then wks.Delete
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
For x = 1 To Worksheets.Count - 1
LR = Application.Max(1, Sheets(x).Cells(Rows.Count, 10).End(xlUp).Row - 3)
With wks.Cells(Rows.Count, 1)
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
.Offset(1).Resize(LR - 9).Value = Sheets(x).Name
End With
Next x
wks.Select
With Application
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set wks = Nothing
End Sub
This errors out with a 1004: Application defined or object defined error on line
.Offset(1, 1).Resize(LR, 22).Value = .Cells(1, 10).Resize(LR, 22).Value
If anyone has any ideas on either how to resolve this I would be extremely grateful.
Please give this a try and tweak it as per your requirement to make sure the correct data is copied starting from the correct row on destination sheet.
Sub ImportData()
Dim LR As Long, dLR As Long, i As Long
Dim wks As Worksheet
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
On Error Resume Next
Set wks = Sheets("RDBMergeSheet")
wks.Cells.Clear
On Error GoTo 0
If wks Is Nothing Then
Set wks = Worksheets.Add(after:=Worksheets(Sheets.Count))
wks.Name = "RDBMergeSheet"
End If
For i = 1 To Worksheets.Count - 1
If Worksheets(i).Name <> wks.Name Then
LR = Application.Max(1, Sheets(i).Cells(Rows.Count, 10).End(xlUp).Row - 3)
If LR > 9 Then
If wks.Range("B1").Value = "" Then
dLR = 1
Else
dLR = wks.UsedRange.Rows.Count + 1
End If
wks.Range("B" & dLR & ":X" & LR - 9).Value = Worksheets(i).Range("B10:X" & LR).Value
wks.Range("A" & dLR).Value = Worksheets(i).Name
End If
End If
Next i
On Error Resume Next
wks.Select
dLR = wks.UsedRange.Rows.Count
wks.Range("A1:A" & dLR).SpecialCells(xlCellTypeBlanks).Formula = "=R[-1]C"
wks.Range("A1:A" & dLR).Value = wks.Range("A1:A" & dLR).Value
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
Set wks = Nothing
End Sub
I encountered a problem in excel, I'm planning to split a multi-valued cell into rows through VBA.
This is my current table
Then I'm trying to make it like this
Thank you
This will do what you want. I'm assuming your 'Emails' column is column B and you start on row 1.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim LastRow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet1").Copy After:=.Worksheets("Sheet1")
Set ws = ActiveSheet
End With
With ws
LastRow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = LastRow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
I'm trying this, but it's not working:
Sub macro1()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LR As Long
With ActiveSheet
LR = .Cells(.Rows.Count, "C").End(xlUp).Row
End With
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If IsError(p) Then GoTo nextr:
Cells(r, 4).Value = .Value & ",newsletter" '***here***
nextr:
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
If I use the following on the line marked here :
Cells(r,4) = "Y"
It works, so I guess I've done my append wrong?
Just to spell out the answer and to format it nicely:
Option Explicit
Sub macro1()
Dim p As Double
Dim LR As Long
Dim r As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LR = ActiveSheet.Cells(ActiveSheet.Rows.Count, "C").End(xlUp).Row
For r = 2 To LR
p = Application.Match(Cells(r, 3), Sheets("Input").Range("C:C"), 0)
If Not IsError(p) Then
ActiveSheet.Cells(r, 4).Value = ActiveSheet.Cells(r, 4).Value & ",newsletter" '***here***
End If
Next r
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
I have an Excel sheet with the following structure:
What I need to do is delete an entire record if either it's Type A or Type B are = 0. As an example, for record 1, I need to delete A & B because B = 0.
I have the following code:
Sub Loop_Example()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "B")
If Not IsError(.Value) Then
If .Value = "0" Then .EntireRow.Delete
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub
Therefore, what I would like to do is add the logic to delete the entire row if the value is 0 and either the row above or below depending on its 'type'.
Thanks.
this should work.
Sub pDeleteRow()
Dim wksData As Worksheet
Dim rngCell As Range
Dim lngCounter As Long
Dim lngTotalCount As Long
Set wksData = Worksheets("Sheet1")
lngTotalCount = wksData.Range("A1").CurrentRegion.Rows.Count
lngCounter = 1
With wksData
While lngCounter <= lngTotalCount
If (UCase(Trim(.Cells(lngCounter, 2))) = "A" Or UCase(Trim(.Cells(lngCounter, 2))) = "B") And UCase(Trim(.Cells(lngCounter, 3))) = "0" Then
.Cells(lngCounter, 1).EntireRow.Delete
lngCounter = lngCounter - 1
lngTotalCount = lngTotalCount - 1
End If
lngCounter = lngCounter + 1
Wend
End With
End Sub
You can Try This:
Sub ConditionalRowDelete()
Set colA = Range("C1", Cells(Rows.Count, "C").End(xlUp))
Set colB = Range("D1", Cells(Rows.Count, "D").End(xlUp))
MsgBox colA.Rows.Count
For i = 1 To colA.Rows.Count
If colB(i) = 0 Then
If colA(i) = "A" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(1, 0).EntireRow).Delete 'Select
End With
'Selection.EntireRow.Select
'MsgBox "found A"
End If
If colA(i) = "B" Then
'colB(i).Select
With colB(i) 'Selection
Application.Union(.EntireRow, .Offset(-1, 0).EntireRow).Delete 'Select
End With
'MsgBox "found B"
End If
End If
Next
End Sub