This forum has been moved to TeachExcel.com
Ask all future questions in the New Excel Forum.
ExcelKey
Sub InsertSomeRows()
'ExcelKey -- Re: MikeLittle
Dim lr As Long
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
'speed up on
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'find last used row on sheet
lr = ws.Cells.Find(what:="*", searchdirection:=xlPrevious, searchorder:=xlByRows).Row
For i = lr To 2 Step -1
With ws.Cells(i, "BD")
If Not IsError(.Value) Then
If .Value <> "" And .Value <> 0 Then
.Offset(1).EntireRow.Insert
ws.Range("A" & i + 1).Value = .Value
ws.Range("A" & i + 1 & ":BD" & i + 1).Interior.ColorIndex = 6
End If
End If
End With
Next i
'speed up off
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
I found where you added the highlight color, and changed it to 0 to make them white.
Sub InsertSomeRows()
Dim lr As Long
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
'speed up on
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'find last used row on sheet
lr = ws.Cells.Find(what:="*", searchdirection:=xlPrevious, searchorder:=xlByRows).Row
For i = lr To 2 Step -1
With ws.Cells(i, "BD")
If Not IsError(.Value) Then
If .Value <> "" And .Value <> 0 Then
.Offset(1).EntireRow.Insert
ws.Range("A" & i + 1 & ":BD" & i + 1).Cells.UnMerge
ws.Range("A" & i + 1).RowHeight = 12.75
ws.Range("A" & i + 1).Value = .Value
End If
End If
End With
Next i
'speed up off
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub
Merged cells are the work of the Devil and should be avoided like the plague.
Sub Allthreemacros()
Range("AR23:AU23").Select
Columns("AU:AU").ColumnWidth = 3.71
Range("AD19:AG19").Select
Columns("AG:AG").ColumnWidth = 4.43
Range("BD22").Select
ActiveCell.FormulaR1C1 = "=VLOOKUP(RC[-31],'Sheet1 (2)'!C[-31]:C,32,0)"
Range("BD22").Select
Selection.Copy
Range("BD23:BD850").Select
ActiveSheet.Paste
Columns("BD:BD").Select
Application.CutCopyMode = False
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
BInsertSomeRows
End Sub
Sub BInsertSomeRows()
Dim lr As Long
Dim i As Long
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
'speed up on
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'find last used row on sheet
lr = ws.Cells.Find(what:="*", searchdirection:=xlPrevious, searchorder:=xlByRows).Row
For i = lr To 2 Step -1
With ws.Cells(i, "BD")
If Not IsError(.Value) Then
If .Value <> "" And .Value <> 0 Then
.Offset(1).EntireRow.Insert
ws.Range("A" & i + 1 & ":BD" & i + 1).Cells.UnMerge
ws.Range("A" & i + 1).RowHeight = 12.75
ws.Range("A" & i + 1).Value = .Value
ws.Range("A" & i + 1 & ":BD" & i + 1).Font.Color = vbRed
End If
End If
End With
Next i
'speed up off
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
CDeletes
End Sub
Sub CDeletes()
'
' Deletes Macro
'
'
Selection.Delete Shift:=xlToLeft
Sheets("Sheet1 (2)").Select
ActiveWindow.SelectedSheets.Delete
End Sub
The way its written right now, it unmerges the whole row above the inserted row
Return to Macros and VBA Questions
Users browsing this forum: No registered users and 230 guests