ClearContents and Shift Data Below up without deleting rows/cells - excel

I automating a spreadsheet cleaning tools that removes data from the spreadsheet if certain values are in a particular column. Originally, it deleted entire rows of data if the specific value is found. However, this is causing numerous reference errors by deleting the rows. Sample of the original code below.
Set rData = .Range("L5:L" & last & ",AX5:AX" & last)
For i = rData.Row To rData.Row + rData.Rows.Count - 1
If .Range("AX" & i) = "DONE" Or .Range("AX" & i) = "CANCEL" Then
.Range("A" & i, "AX" & i).Copy
bottom = activewkb.Worksheets("OrderStatus").Range("I" & Rows.Count).End(xlUp).Row + 1
activewkb.Worksheets("OrderStatus").Range("A" & bottom).PasteSpecial Paste:=xlPasteValues
If i > 0 Then
.Range("D" & i & ":CA" & i).ClearContents
End If
End If
Next i
The easiest way to get rid of the reference errors is to clear the contents from column D through DD if the requirements are satisfied then shift all of the data below it up for column D to DD up one row. The new code is below. I am getting an error on the .Range("D" & i).Offset(1,0).Value line.
Set rData = .Range("L5:L" & last & ",AX5:AX" & last)
For i = rData.Row To rData.Row + rData.Rows.Count - 1
If .Range("AX" & i) = "DONE" Or .Range("AX" & i) = "CANCEL" Then
.Range("A" & i, "AX" & i).Copy
bottom = activewkb.Worksheets("OrderStatus").Range("I" & Rows.Count).End(xlUp).Row + 1
activewkb.Worksheets("OrderStatus").Range("A" & bottom).PasteSpecial Paste:=xlPasteValues
If i > 0 Then
.Range("D" & i & ":CA" & i).ClearContents
.Range("D" & i).Offset(1, 0).Value
.Offset(1, 0).Select
End If
End If
Next i
Any suggestions are appreciated! Thanks in advance.

Related

Excel VBA Using Sum in a For Next Loop

I have a for next loop where I have dimmed the row number as "i". I would like to sum up the following range - within row "i", from column C to M in a For Next Loop. I have the following codes:
Range("N" & i).Value = Application.WorksheetFunction.Sum(Range("C" & i & ":" & "M" & i))
I have also tried the following:
Range("N" & i).Value = Application.WorksheetFunction.Sum(Range("C" & i), Range("M" & i))
Range("N" & i).Value = Application.WorksheetFunction.Sum("C" & i & ":" & "M" & i)
I guess my main problem is I cannot figure out the correct way to reference the dynamic row number i in the code, hence the error. Would appreciate your help.

VBA - IFELSE and Continuous Looping

I want to have 2 formulas with continuous looping as long as there is value in the cell next to the targeted cell, thus i need to have ifelse function but with continuous looping aswell. for now i don't know how to insert the second formula.
Range("D9").Select
Set ws = Sheets("LAP KEL BIAYA")
lastRow = ws.Range("C" & Rows.Count).End(xlUp).Row
With ws
For i = 9 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Function Total(Text, Number)
.Range("D" & i).Formula = "=IF(RC[-3]=""B"",IF(AND(R4C3>0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3>0,R5C3=""""),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C[47],'LAP KEL BIAYA'!RC[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),IF(AND(R4C3=0,R5C3=0),SUMIFS(F" & _
"BL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C[47],RC[-1]),"""")))))" & _
""
ElseIf Total = "False" Then
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
.Range("D" & i).Formula = "=IF(AND(R4C3>0,R5C3>0,OR(R[-1]C1=""7"",R[-1]C1=""5"",R[-1]C1=""4"")),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(AND(R4C3>0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[21],R4C3,FBL3N!C[16],R7C4,FBL3N!C,'LAP KEL BIAYA'!R[-1]C[-1]),IF(AND(R4C3=0,R5C3>0),SUMIFS(FBL3N!C[11],FBL3N!C[22],R5C3,FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1]),IF(" & _
"AND(R4C3=0,R5C3=0),SUMIFS(FBL3N!C[11],FBL3N!C[16],R7C4,FBL3N!C,R[-1]C[-1])))))" & _
""
.Range("D" & i).Font.Color = vbRed
End If
Next i
End Function
End With

How do I set the value of a do while inner loop, nested in a for loop?

I have a report that downloads from a client's SharePoint. The report varies in length depending on the site and time range I am running it for. Most items come across where their information is nicely laid out in columns on one row per each item, but in the case where there is a split decision it puts the decision into multiple lines and does not keep the other necessary information in those lines. I'm trying to take the split dispositions and find loop through the following rows to copy the quantities and paste them in the columns based on their disposition.
I have the Outer loop set up and it works. When I set up the inner loop it doesn't take the value of the outer loop and add 1 row to it.
Sub Split_Dispositions_One_Line()
Dim LastRow As Integer
Dim i As Integer
i = x + i
LastRow = Worksheets("Data").UsedRange.Rows.Count
With Worksheets("Data")
For x = 1 To LastRow
If InStr(Range("Y" & x).Value, "Split Disposition") Then
Do While Application.WorksheetFunction.IsText(Range("AI" & i).Value)
If InStr(Range("AI" & i).Value, "Release to Good Inventory") Then
Range("AH" & i).Copy Range("AK" & x)
ElseIf InStr(Range("AI" & i).Value, "Donate") Then
Range("AH" & i).Copy Range("AL" & x)
ElseIf InStr(Range("AI" & i).Value, "Destroy, Landfill") Then
Range("AH" & i).Copy Range("AM" & x)
ElseIf InStr(Range("AI" & i).Value, "Destroy, Animal Feed") Then
Range("AH" & i).Copy Range("AN" & x)
ElseIf InStr(Range("AI" & i).Value, "Return To Plant") Then
Range("AH" & i).Copy Range("AO" & x)
End If
Loop
End If
Next x
End With
End Sub
My goal is to loop through the rows and when I come across "Split Disposition" in column Y it will then go to the inner loop, drop 1 row down from where it found "Split Disposition" in Y and loop through those rows and if AI contains text it will copy the value in AH and paste it to the column that corresponds to AH in the original row where it found "Split Disposition" in column Y. The number of these lines varies, but they are always one after the other.
Said differently if the loop finds "Split Disposition" in cell Y5, then the inner loop will start at AI6, if it has text copy AH6 and Paste into Column AK5, then if AI7 contains text it will copy AH7 and might paste it in AL5 (if that is the column that matches AH7).

Changed the inner loop to a for loop with an exit option and that seems to work.
Sub Split_Dispositions_One_Line()
Dim LastRow As Integer
Dim i As Integer
LastRow = Worksheets("Data").UsedRange.Rows.Count
With Worksheets("Data")
For x = 1 To LastRow
If InStr(Range("Y" & x).Value, "Split Disposition") Then
For i = x + 1 To LastRow
If Application.WorksheetFunction.IsText(Range("AI" & i).Value) Then
If InStr(Range("AI" & i).Value, "Release to Good Inventory") Then
Range("AH" & i).Copy Range("AK" & x)
ElseIf InStr(Range("AI" & i).Value, "Donate") Then
Range("AH" & i).Copy Range("AL" & x)
ElseIf InStr(Range("AI" & i).Value, "Destroy, Landfill") Then
Range("AH" & i).Copy Range("AM" & x)
ElseIf InStr(Range("AI" & i).Value, "Destroy, Animal Feed") Then
Range("AH" & i).Copy Range("AN" & x)
ElseIf InStr(Range("AI" & i).Value, "Return To Plant") Then
Range("AH" & i).Copy Range("AO" & x)
End If
ElseIf IsEmpty(Range("AI" & i).Value) Then
Exit For
End If
Next i
End If
Next x
End With
End Sub

Clearing Contents of a Variable Row

So I am new to this language and am trying to get my head around it. This piece of code is for work and the section here was hugely assisted by an amazing person on this website.
This piece should copy over a row of information to a different spreadsheet when the box in the I Column turns to 7. And thanks to that person it works pretty perfectly.
The next question on my mind though is how to the delete the original row in the first spreadsheet.
I can't use a range like "A9:M9" as the row will not always been in that fixed place.
I tried using:
If Source.Column = 9 And Source.Value = "7 - engaged" Then
Range("A:M").Select
Selection.ClearContents
But this wiped the entire worksheet.
Is there any way to just delete the one row that's been copied?
If Source.Column <> 9 Then Exit Sub
If Source.Value <> "7 - engaged" Then Exit Sub
If MsgBox("Client status selected as engaged. Confirm to post to tank.",
vbOKCancel) = vbOK Then
With ThisWorkbook.Worksheets("Tank")
Dim rowToPasteTo As Long
rowToPasteTo = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
.Range("A" & rowToPasteTo & ":" & "D" & rowToPasteTo).Value =
Sh.Range("A" & Source.Row & ":" & "M" & Source.Row).Value
.Range("G" & rowToPasteTo & ":" & "H" & rowToPasteTo).Value =
Sh.Range("E" & Source.Row & ":" & "F" & Source.Row).Value
.Range("S" & rowToPasteTo & ":" & "U" & rowToPasteTo).Value =
Sh.Range("K" & Source.Row & ":" & "M" & Source.Row).Value
End With
End If
If Source.Column = 9 And Source.Value = "7 - engaged" Then`

Not sure if you want to delete the entire row or clear the cells contents:
If Source.Column = 9 And Source.Value = "7 - engaged" Then
' Option 1 - deletes the entire row
Source.EntireRow.Delete
' Option 2 - clears the contents
Source.EntireRow.ClearContents
End Sub

Move records from repeating rows to columns with Excel and VBA

I have about 70,000 rows of data and two columns (Field,Data) which repeats every 50-100 rows (Record). I would like to write something that searches for the values based on "Field Text" (I'm only interested in about 5 fields) and paste the value into a new worksheet with rows as records and columns as fields. The first field I'm searching for will need to indicate new row/record.
My first attempt at this failed, and I've found little help on the forums. Although it looks like maybe a pivot table could do this?
Visual of what I'd like to do:
Example
EDIT:
I got the result I wanted but my do until "END" isnt catching. I do have "END" in the last cell of the data. Also, I'm sure there is a more efficient way to do this, any advice? Thanks!
Sub TracePull()
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Do Until ActiveCell = "OTDRFilename"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRFilename" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
j = j + 1
'Else
' i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan length"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan length" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRAverage loss"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRAverage loss" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRSpan ORL"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRSpan ORL" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
Range("A" & i).Select
Do Until ActiveCell = "OTDRWavelength"
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Activate
Loop
If ActiveCell = "OTDRWavelength" Then
ActiveWorkbook.Sheets("Trace").Range("B" & i).Copy
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).PasteSpecial Paste:=xlValue
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
i = i + 1
End If
i = i + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Range("A" & i).Select
Loop
End Sub

I think your main problem is incrementing i twice (which passes 'END' cell) at the bottom of your code.
One way to make it more readable is by using select case. Also, you can speed up the code by assigning the value directly (without copy paste) and by turning off screen updating since you have 70,000 rows. Those things will improve performance considerably.
Sub TracePull()
ScreenUpdating = False
Dim i As Long
Dim j As Long
i = 1
j = 1
ActiveWorkbook.Sheets("Trace").Range("A1").Select
Do Until Range("A" & i) = "END"
Select Case ActiveCell.Text
Case "OTDRFilename"
ActiveWorkbook.Sheets("Sheet1").Range("A" & j + 1).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan length"
ActiveWorkbook.Sheets("Sheet1").Range("B" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan loss"
ActiveWorkbook.Sheets("Sheet1").Range("C" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRAverage loss"
ActiveWorkbook.Sheets("Sheet1").Range("D" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRSpan ORL"
ActiveWorkbook.Sheets("Sheet1").Range("E" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
Case "OTDRWavelength"
ActiveWorkbook.Sheets("Sheet1").Range("F" & j).Value = ActiveWorkbook.Sheets("Trace").Range("B" & i).Value
End Select
i = i + 1
j = j + 1
ActiveWorkbook.Sheets("Trace").Range("A" & i).Select
Loop
ScreenUpdating = True
End Sub
You might also want to consider defining the workbook and worksheet rather than relying upon activesheet. In addition, the code with break if someone forget to have 'END' entered in the last cell, so maybe just get last cell used instead of looking for 'END'
Dim wb As Workbook
Dim wskA As Worksheet
Dim wskB As Worksheet
wb = ActiveWorkbook
wskA = wb.Sheets("Trace")
wskB = wb.Sheets("Sheet1")
numofrows = wskA.Offset(wskA.Rows.Count - 1, 0).End(xlUp).Row
wskA.Range("A1").Select
Do Until i > numofrows
Select Case ActiveCell.Text
Case "OTDRFilename"
wskB.Range("A" & j + 1).Value = wskA.Range("B" & i).Value

Resources