VBA - Delete or add rows based on number of merged rows in another sheet

[Tussas]

Hi all,

I have a macro giving me headaches..

Its goal is:
1. To copy 8 columns from 'Global List' to 'Front'. Global List sheet has some merged cells and Front sheet can't have them so as to be aligned with the rest of the info already there when I copy these columns.

I use this code:

Sub Front()
Dim LastRow As Long
LastRow = Range("B" & Rows.count).End(xlUp).Row
Worksheets("Front").Range("A1:D400").Value = Worksheets("Global List").Range("A1:D400").Value
Worksheets("Front").Range("E1:H400").Value = Worksheets("Global List").Range("G1:J400").Value

Dim CopyRng As Range, PasteFront As Range, CopyOffer As Range, PasteOffer As Range

Set CopyRng = Application.Selection
Set CopyRng = Worksheets("Global List").Range("A1:D400")
Set PasteFront = Worksheets("Front").Range("A1:D400")
CopyRng.Copy
PasteFront.Parent.Activate
PasteFront.PasteSpecial xlPasteFormats

Set CopyOffer = Application.Selection
Set CopyOffer = Worksheets("Global List").Range("G1:J400")
Set PasteOffer = Worksheets("Front").Range("E1:H400")
CopyOffer.Copy
PasteOffer.Parent.Activate
PasteOffer.PasteSpecial xlPasteFormats


Dim i As Integer
Dim count As Integer

For i = 3 To 200
If Worksheets("Front").Range("C" & i).Value = "" Then
count = count + 1
End If
Next i


While count <> 0

For i = 3 To 200
If Worksheets("Front").Range("C" & i).Value = "" Then
Worksheets("Front").Range("C" & i).UnMerge
Worksheets("Front").Range("C" & i).Delete Shift:=xlUp
Worksheets("Front").Range("A" & i).Delete Shift:=xlUp
Worksheets("Front").Range("B" & i).Delete Shift:=xlUp
Worksheets("Front").Range("D" & i).Delete Shift:=xlUp
Worksheets("Front").Range("E" & i).Delete Shift:=xlUp
Worksheets("Front").Range("F" & i).Delete Shift:=xlUp
Worksheets("Front").Range("G" & i).Delete Shift:=xlUp
Worksheets("Front").Range("H" & i).Delete Shift:=xlUp
End If
Next i
count = count - 1
Wend

Application.CutCopyMode = False

End Sub


Problem:
1. Column A has merged cells and my code maintains it merged but its info is deleted..
2. I used row 400 as last row but what I want (as to be more efficient) is to find LastRow and map until it.


New thing I'm trying to do:
I have another sheet where I want to copy that same information to. But this sheet also has merged cells and in a number not identical to Global List.
I've found the logic of what I need but I don't know how to adapt it to code..

Basically I need to copy the information from Global List (A, B, C, D). When I copy, this 4 columns, I need to insert or delete blank rows and merge them to the existent cells so this information has the same number of rows as the merged cells of column I.

e.g. Global has rows 3 and 4 merged and 5 is single. I need to copy it to "Live" sheet. But Live has rows 3, 4 and 5 merged in column I and 6 is single. So in order to copy correctly I need to add a blank row as row #5.

So my question is: How can I find the number of rows merged in column I so as to find out how much rows I need to delete or add when I copy from Global?

This logic makes me think it's possible to do it with <acronym title="visual basic for applications">vba</acronym>/macro. But how?
Am I even right?

Thanks,
Tiago

 

[Kuljack]

I may be misunderstanding your intentions, but try this out and let me know:

This will transfer information from Range A in sheet 1 to Range A in sheet 2 eliminating spaces caused by merged cells in Range A, and repeat for columns B:D. Additional For Each loops can be added with modifications to the ranges/columns below. Seems like you will know what to modify in the code below to meet your range focus, but the range provided in the For Each should eliminate the need to focus on D400.

Sub TestThis()

Dim Value As String
Dim Value2 As String
Dim Mark As Range
Dim X As Integer
Dim Y As Integer

X = 1

Application.ScreenUpdating = False

For Each bump In Range(Cells(1, 1), Cells(Rows.Count, "A").End(xlUp))
    Value = Cells(bump.Row, 1)
    If Value <> "" Then
        Worksheets("Sheet2").Select
        Set Mark = Worksheets("Sheet2").Cells(X, "A")
        Value2 = Mark.Value
            Do Until Value2 = vbNullString
                X = X + 1
                Set Mark = Worksheets("Sheet2").Cells(X, "A")
                Value2 = Mark.Value
            Loop
        Mark.Value = Value
    Else
    End If
    Worksheets("Sheet1").Select
Next

X = 1

For Each bump In Range(Cells(1, 2), Cells(Rows.Count, "B").End(xlUp))
    Value = Cells(bump.Row, 2)
    If Value <> "" Then
        Worksheets("Sheet2").Select
        Set Mark = Worksheets("Sheet2").Cells(X, "B")
        Value2 = Mark.Value
            Do Until Value2 = vbNullString
                X = X + 1
                Set Mark = Worksheets("Sheet2").Cells(X, "B")
                Value2 = Mark.Value
            Loop
        Mark.Value = Value
    Else
    End If
    Worksheets("Sheet1").Select
Next

X = 1

For Each bump In Range(Cells(1, 3), Cells(Rows.Count, "C").End(xlUp))
    Value = Cells(bump.Row, 3)
    If Value <> "" Then
        Worksheets("Sheet2").Select
        Set Mark = Worksheets("Sheet2").Cells(X, "C")
        Value2 = Mark.Value
            Do Until Value2 = vbNullString
                X = X + 1
                Set Mark = Worksheets("Sheet2").Cells(X, "C")
                Value2 = Mark.Value
            Loop
        Mark.Value = Value
    Else
    End If
    Worksheets("Sheet1").Select
Next

X = 1

For Each bump In Range(Cells(1, 4), Cells(Rows.Count, "D").End(xlUp))
    Value = Cells(bump.Row, 4)
    If Value <> "" Then
        Worksheets("Sheet2").Select
        Set Mark = Worksheets("Sheet2").Cells(X, "D")
        Value2 = Mark.Value
            Do Until Value2 = vbNullString
                X = X + 1
                Set Mark = Worksheets("Sheet2").Cells(X, "D")
                Value2 = Mark.Value
            Loop
        Mark.Value = Value
    Else
    End If
    Worksheets("Sheet1").Select
Next







Application.ScreenUpdating = True


End Sub