VBA code expert help please

[terry3232]

Hi all,

I got the following code as a part of bigger macro working flawlessly to find the target cells in a column, mark the beginning and end of the target, then insert some cells and move things to the right for existing content:

<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o> </o>
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set lookIn = Range("c1:c" & lastRow)
Set firstCell = lookIn.Find(What:="xmxy")
firstAddress = firstCell.Address
If Not firstCell Is Nothing Then
Do
Set lastCell = lookIn.Find(What:="xmx", after:=firstCell)
If Not lastCell Is Nothing Then
Range(firstCell, lastCell).Insert Shift:=xlToRight
End If
<o> </o>
Set firstCell = lookIn.Find(What:="xmxy", after:=lastCell.Offset(, -1))
<o> </o>
Loop While Not firstCell Is Nothing
End If
Application.ScreenUpdating = True


However, the problem is when the cells are inserted, the formating changes for the inserted cells, thus messing up the look and feel. Is there anyway to tell excel to retain the existing formating for the cells to the left or right for the cells that are inserted? I tried to mesh the following codes to copy the range near by and make excel past formats only, but it did not work. Not sure what is wrong?


Range(firstCell, lastCell).Offset(, -3).Select
Selection.Copy
Range(firstCell, lastCell).Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Please help!!!!

 

[AlphaFrog]

When you insert cells, you want all the columns to retain their original formatting? Is that correct?

Also, when you insert cells, do any cells to the right of the insertion have formulas? It matters on how the code might work. Example: If your FirstCell:LastCell range is say C10:C20, and the current last used column is say column G, does range C10:G20 have any formulas? If no, the macro could copy just the values from C10:G20 to D10:H20. That way the original formatting is retained, but if there were any formulas, they wouldn't be copied in this case.

 

[terry3232]

Hi,

Thanks for the response. Well, I will be inserting cells in the specific vertical range of select columns, so yes, I want the inserted cells to retain the formatting to the right or the left of the inserted range.

There are no formulas anywhere! I wonder if there is any internal command to turn on so that it does the insertion while retaining the same cell formats of those nearby.

 

[AlphaFrog]

Test this on a copy of your data...

Sub Shift_Values()

    Dim FirstCell As Range, LastCell As Range, LastRow As Long, LastCol As Long
    Dim LookIn As Range, rngXMXY As Range
    
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row
    Set LookIn = Range("C1:C" & LastRow)
    
    LastCol = Cells.Find("*", , , , xlByColumns, xlPrevious).Column
    
    Set FirstCell = LookIn.Find("xmxy", , , xlWhole, xlByRows, xlNext, False)
    
    If Not FirstCell Is Nothing Then

        Set LastCell = LookIn.Find("xmxy", , , xlWhole, xlByRows, xlPrevious, False)
        
        Set rngXMXY = Range(FirstCell, Cells(LastCell.Row, LastCol))
        rngXMXY.Offset(, 1).Value = rngXMXY.Value
        Range(FirstCell, LastCell).ClearContents
        
    End If
    
End Sub

 

[terry3232]

Hi,

thanks for helping, but unfortunately it does not work.

Basically, every works for all the other codes I wrote, then in Column B or Column C, there will be ranges marked by "xmxy" (the beginning cell) and "xmx" (the ending cell).

All I want to do, is to select those ranges, then copy those ranges one or two column to the left, but copy the formats only.

Seemingly simple, but just cannot mesh the codes. Just for the heck of it, here is the entire VB codes without the format-copying part yet for your reference. If you could make it work, it would be wonderful!!!


Sub ShiftRightMScienceCombined1()
' This section of code will update comparison table headers.
Dim RowNum As Long
Dim lastRow As Long
With ActiveSheet
lastRow = .UsedRange.Rows.Count
For RowNum = lastRow To 1 Step -1
If Range("A" & RowNum) = "Comparisons of Column Means(a)" Then
Range("A" & RowNum) = "Comparisons of Column Means"
End If
If Range("A" & RowNum) = "Comparisons of Column Means(b)" Then
Range("A" & RowNum) = "Comparisons of Column Means"
End If
If Range("A" & RowNum) = "Comparisons of Column Means(a,b)" Then
Range("A" & RowNum) = "Comparisons of Column Means"
End If
If Range("A" & RowNum) = "Comparisons of Column Proportions(a)" Then
Range("A" & RowNum) = "Comparisons of Column Proportions"
End If
If Range("A" & RowNum) = "Comparisons of Column Proportions(b)" Then
Range("A" & RowNum) = "Comparisons of Column Proportions"
End If
If Range("A" & RowNum) = "Comparisons of Column Proportions(a,b)" Then
Range("A" & RowNum) = "Comparisons of Column Proportions"
End If
Next RowNum
End With
' This section of code will delete footers.
Dim f1 As String, f2 As String, f3 As String, f4 As String, f5 As String, f6 As String
f1 = "a. Tests are adjusted for all pairwise comparisons within a row of each innermost subtable using the Bonferroni correction."
f2 = "a. This category is not used in comparisons because its column proportion is equal to zero or one."
f3 = "a. Pairwise comparisons are not performed for some subtables because of numerical problems."
f4 = "a. This category is not used in comparisons because the sum of case weights is less than two."
f5 = "a. Cell counts in some subtables are not integers. They were rounded to the nearest integers before performing pairwise comparisons."
f16 = "a. Cell counts of some categories are not integers. They were rounded to the nearest integers before performing column proportions tests."
f6 = "b. Tests are adjusted for all pairwise comparisons within a row of each innermost subtable using the Bonferroni correction."
f7 = "b. This category is not used in comparisons because its column proportion is equal to zero or one."
f8 = "b. Pairwise comparisons are not performed for some subtables because of numerical problems."
f9 = "b. This category is not used in comparisons because the sum of case weights is less than two."
f10 = "b. Cell counts in some subtables are not integers. They were rounded to the nearest integers before performing pairwise comparisons."
f17 = "b. Cell counts of some categories are not integers. They were rounded to the nearest integers before performing column proportions tests."
f11 = "c. Tests are adjusted for all pairwise comparisons within a row of each innermost subtable using the Bonferroni correction."
f12 = "c. This category is not used in comparisons because its column proportion is equal to zero or one."
f13 = "c. Pairwise comparisons are not performed for some subtables because of numerical problems."
f14 = "c. This category is not used in comparisons because the sum of case weights is less than two."
f15 = "c. Cell counts in some subtables are not integers. They were rounded to the nearest integers before performing pairwise comparisons."
f18 = "c. Cell counts of some categories are not integers. They were rounded to the nearest integers before performing column proportions tests."

lastRow = Range("A65536").End(xlUp).Row
For i = 1 To lastRow
If Range("A" & i).Value = f1 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f2 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f3 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f4 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f5 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f6 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f7 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f8 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f9 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f10 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f11 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f12 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f13 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f14 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f15 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f16 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f17 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
If Range("A" & i).Value = f18 Then
ActiveSheet.Rows(i).EntireRow.Delete
End If
Next i

' This section of code will reference where to insert page breaks.
Dim t1 As String, t2 As String
t1 = "Results are based on two-sided tests assuming equal variances with significance level 0.05. For each significant pair, the key of the smaller category appears under the category with larger mean."
t2 = "Results are based on two-sided tests with significance level 0.05. For each significant pair, the key of the category with the smaller column proportion appears under the category with the larger column proportion."
lastRow = Range("A65536").End(xlUp).Row
For i = 1 To lastRow
If Range("A" & i).Value = t1 Then
If Range("A" & i + 1).Value = "" Then
If Not Range("A" & i + 2).Value = "Comparisons of Column Means" Then
Range("A" & i + 1).Value = "PB"
End If
End If
End If
If Range("A" & i).Value = t2 Then
If Range("A" & i + 1).Value = "" Then
If Not Range("A" & i + 2).Value = "Comparisons of Column Means" Then
Range("A" & i + 1).Value = "PB"
End If
End If
End If
Next i
' This section of code inserts page breaks.
Dim PBR As Range
Dim firstAddress As String
Dim Search1 As String
Search1 = "PB"
If Search1 = "" Then
Exit Sub
End If
With ActiveSheet.UsedRange
Set PBR = .Find(What:=Search1, lookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
If Not PBR Is Nothing Then
firstAddress = PBR.Address
Do
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=PBR
Set PBR = .FindNext(PBR)
Loop While Not PBR Is Nothing And PBR.Address <> firstAddress
End If
End With

' This section will prepare properties, headers, and footers.
Dim Y As String
Dim lpclass As String
ActiveWorkbook.BuiltinDocumentProperties.Item("Author").Value = "Terry Pan"
ActiveWorkbook.BuiltinDocumentProperties.Item("Company").Value = "SMG"
X = InputBox("Project")
ActiveWorkbook.BuiltinDocumentProperties.Item("Title").Value = X
Y = InputBox("Report")
ActiveWorkbook.BuiltinDocumentProperties.Item("Subject").Value = Y
Z = InputBox("Manager")
ActiveWorkbook.BuiltinDocumentProperties.Item("Manager").Value = Z
On Error GoTo errorHandler
Worksheets("Sheet").Columns("B:B").ColumnWidth = 25
Worksheets("Sheet").Columns("A:A").ColumnWidth = 40
Worksheets("Sheet").Columns("C:BA").ColumnWidth = 8
Cells.Select
Selection.RowHeight = 12
Sheets("Sheet").Name = Y
lpclass = Space$(100)
With ActiveSheet.PageSetup
.LeftFooter = "&""Tahoma,Regular""SMG Confidential"
.CenterFooter = "&""Tahoma,Regular""&F &A"
.RightFooter = "&""Tahoma,Regular""Page &P of &N"
.CenterHeader = "&""Tahoma""&B &14" & X & lpclass & Y
.HeaderMargin = Application.InchesToPoints(0.5)
.FooterMargin = Application.InchesToPoints(0.5)
.PaperSize = xlPaperLetter
.Zoom = 75
.FitToPagesWide = 1
.FitToPagesTall = False
End With
' This section will clean up the base size text.
'Dim Myrange As Range, C As Range
' Set Myrange = Range("B1:B65000")
' For Each C In Myrange
' If C.Value = "Valid N" Then
' C.Offset(0, -1).ClearContents
' End If
' Next C
' This code will reset vertical breaks
Dim LastColumn1 As Long
Dim LastRow1 As Long
ActiveWindow.SelectedSheets.VPageBreaks.Add Before:=Range("AB1")
LastRow1 = Cells.Find(What:="*", after:=Range("A1"), lookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LastColumn1 = Cells.Find(What:="*", after:=Range("A1"), lookIn:=xlValues, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ActiveSheet.PageSetup.PrintArea = "A1:" & Cells(LastRow1, LastColumn1).Address
' This section of code will remove the page break references .
lastRow = Range("A65536").End(xlUp).Row
For i = 1 To lastRow
If Range("A" & i).Value = "PB" Then
Range("A" & i).Value = " "
End If
Next i
' Clean Un/weighted base size text
'LastRow3 = Range("B65536").End(xlUp).Row
' For i = 1 To LastRow3
' If Range("B" & i).Value = "Unweighted" Then
' Range("B" & i).Value = " "
' End If
' If Range("B" & i).Value = "Weighted" Then
' Range("B" & i).Value = " "
' End If
' Next i
' Remove all instances of merged cells with the word Unweighted
'LastRow4 = Range("A65536").End(xlUp).Row
' For i = 1 To LastRow4
' If Range("A" & i).MergeCells = True Then
' If Range("A" & i).Value = "Unweighted" Then
' Range("A" & i).MergeCells = False
' End If
' End If
' Next i
'LastRow5 = Range("A65536").End(xlUp).Row
' For i = 1 To LastRow5
' If Range("A" & i).MergeCells = True Then
' If Range("A" & i).Value = "Weighted" Then
' Range("A" & i).MergeCells = False
' End If
' End If
' Next i
LastRow6 = Range("B65536").End(xlUp).Row
For i = 1 To LastRow6
If Range("B" & i).Value = "Unweighted" Then
Range("A" & i).UnMerge
Range("A" & i).ClearContents
End If
If Range("B" & i).Value = "Weighted" Then
Range("A" & i).UnMerge
Range("A" & i).ClearContents
End If
Next i
' Remove all instances of merged cells with the word Unweighted
LastRow4 = Range("A65536").End(xlUp).Row
For i = 1 To LastRow4
If Range("A" & i).MergeCells = True Then
If Range("A" & i).Value = "Unweighted" Then
Range("A" & i).MergeCells = False
End If
End If
Next i
LastRow5 = Range("A65536").End(xlUp).Row
For i = 1 To LastRow5
If Range("A" & i).MergeCells = True Then
If Range("A" & i).Value = "Weighted" Then
Range("A" & i).MergeCells = False
End If
End If
Next i
LastRow50 = Range("A65536").End(xlUp).Row
For i = 1 To LastRow5
If Range("A" & i).MergeCells = True Then
If Range("A" & i).Value = "Valid N" Then
Range("A" & i).MergeCells = False
End If
End If
Next i
' Clean Un/weighted base size text
LastRow3 = Range("B65536").End(xlUp).Row
For i = 1 To LastRow3
If Range("A" & i).Value = "Unweighted" Then
Range("A" & i).Value = " "
Range("B" & i).Value = "Unweighted "
End If
If Range("A" & i).Value = "Weighted" Then
Range("A" & i).Value = " "
Range("A" & i).Value = "Weighted "
End If
Next i
LastRow2 = Range("A65536").End(xlUp).Row
For i = 1 To LastRow2
If Range("A" & i).Value = "Weighted " Then
Range("A" & i).Value = " "
Range("B" & i).Value = "Weighted "
End If
Next i
LastRow20 = Range("A65536").End(xlUp).Row
For i = 1 To LastRow20
If Range("A" & i).Value = "Valid N" Then
Range("A" & i).Value = " "
Range("B" & i).Value = "Valid N"
End If
Next i
Dim vList, lArrCounter As Long
Dim rngFound As Range, rngToDelete As Range, sFirstAddress As String
Application.ScreenUpdating = False
vList = Array("Table 1")
For lArrCounter = LBound(vList) To UBound(vList)
With ActiveSheet.UsedRange
Set rngFound = .Find( _
What:=vList(lArrCounter), _
after:=.Cells(1), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
sFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(after:=rngFound)
Do Until rngFound.Address = sFirstAddress
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(after:=rngFound)
Loop
End If
End With
Next lArrCounter
If Not rngToDelete Is Nothing Then rngToDelete.Offset(-1, 0).EntireRow.Delete
Application.ScreenUpdating = True

Application.ScreenUpdating = False
vList = Array("Table 1")
For lArrCounter = LBound(vList) To UBound(vList)
With ActiveSheet.UsedRange
Set rngFound = .Find( _
What:=vList(lArrCounter), _
after:=.Cells(1), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
sFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(after:=rngFound)
Do Until rngFound.Address = sFirstAddress
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(after:=rngFound)
Loop
End If
End With
Next lArrCounter
If Not rngToDelete Is Nothing Then rngToDelete.Offset(1, 0).EntireRow.Delete
Application.ScreenUpdating = True

Application.ScreenUpdating = False
vList = Array("Table 1")
For lArrCounter = LBound(vList) To UBound(vList)
With ActiveSheet.UsedRange
Set rngFound = .Find( _
What:=vList(lArrCounter), _
after:=.Cells(1), _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
sFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(after:=rngFound)
Do Until rngFound.Address = sFirstAddress
If Intersect(rngToDelete, rngFound.EntireRow) Is Nothing Then
Set rngToDelete = Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(after:=rngFound)
Loop
End If
End With
Next lArrCounter
If Not rngToDelete Is Nothing Then rngToDelete.EntireRow.Delete
Application.ScreenUpdating = True
errorHandler:
MsgBox Error
Dim q As String
q1 = "xdummyx"
lastRow = Range("A65536").End(xlUp).Row
For i = 1 To lastRow
If Range("C" & i).Value = q1 Then
Range("C" & i).Value = ""
End If
Next i
Dim j As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
If Left(Range("A" & i).Value, 27) = Left("Comparisons of Column Means", 27) Then Range("A" & i).MergeCells = False
If Left(Range("A" & i).Value, 33) = Left("Comparisons of Column Proportions", 33) Then Range("A" & i).MergeCells = False
If Cells(i, "A").Value = "Results are based on two-sided tests assuming equal variances with significance level 0.05. For each significant pair, the key of the smaller category appears under the category with larger mean." Then Range("A" & i).MergeCells = False
If Cells(i, "A").Value = "Results are based on two-sided tests with significance level 0.05. For each significant pair, the key of the category with the smaller column proportion appears under the category with the larger column proportion." Then Range("A" & i).MergeCells = False
Next i
lastRow = Range("A" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
If Left(Range("A" & i).Value, 27) = Left("Comparisons of Column Means", 27) Then Range("B" & i) = "xmxy"
If Left(Range("A" & i).Value, 33) = Left("Comparisons of Column Proportions", 33) Then Range("C" & i) = "xmxy"
If Cells(i, "A").Value = "Results are based on two-sided tests assuming equal variances with significance level 0.05. For each significant pair, the key of the smaller category appears under the category with larger mean." Then Range("B" & i) = "xmx"
If Cells(i, "A").Value = "Results are based on two-sided tests with significance level 0.05. For each significant pair, the key of the category with the smaller column proportion appears under the category with the larger column proportion." Then Range("C" & i) = "xmx"
Next i
Dim firstCell As Range
Dim lastCell As Range
Dim lookIn As Range
Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set lookIn = Range("B1:B" & lastRow)
Set firstCell = lookIn.Find(What:="xmxy")
firstAddress = firstCell.Address
If Not firstCell Is Nothing Then
Do
Set lastCell = lookIn.Find(What:="xmx", after:=firstCell)
If Not lastCell Is Nothing Then
Range(firstCell, lastCell).Insert Shift:=xlToRight
End If
Set firstCell = lookIn.Find(What:="xmxy", after:=lastCell.Offset(, -1))
Loop While Not firstCell Is Nothing
End If
Application.ScreenUpdating = True

Application.ScreenUpdating = False
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Set lookIn = Range("c1:c" & lastRow)
Set firstCell = lookIn.Find(What:="xmxy")
firstAddress = firstCell.Address
If Not firstCell Is Nothing Then
Do
Set lastCell = lookIn.Find(What:="xmx", after:=firstCell)
If Not lastCell Is Nothing Then
Range(firstCell, lastCell).Insert Shift:=xlToRight
End If
Set firstCell = lookIn.Find(What:="xmxy", after:=lastCell.Offset(, -1))
Loop While Not firstCell Is Nothing
End If
Application.ScreenUpdating = True
lastRow = Range("D" & Rows.Count).End(xlUp).Row
For i = 1 To lastRow
If Cells(i, "D").Value = "xmxy" Then Range("D" & i) = ""
If Cells(i, "D").Value = "xmx" Then Range("D" & i) = ""
If Cells(i, "c").Value = "dummy" Then Range("c" & i) = ""
If Cells(i, "c").Value = "0" Then Range("c" & i) = ""
Next i
Application.ScreenUpdating = True

End Sub