CODEWITHSUNDEEP
vbaexcel
manu
manu

Reputation: 942

Copy from a range and past in another sheet in the next empty cell in a row

I would like to have some tips to start a VBA code:

I have 2 sheets. Each row of the sheet(2) has text in each cells but between them it can have some empty cell. My goal is to copy start from the row1 of sheet(2) from A1 to E1 and past it in the sheet(1) row 1 but without empty cell between them.

I edit my post because i did not thought about this important details. I would like to erase any duplicate in the same row but to keep the first entry.

And repeat the operation until the last row.

Data exemple:

Worksheet(2): row1 cell1, cell2, cell3,cell4,cell5:

**ABC**,   ,DEF,**ABC**,GHI

row(2) cell1, cell2, cell3,cell4,cell5:

ZZZ,  ,   ,   ,YEU

Resultat expected: Worksheet(1): row1 cell1, cell2, cell3,cell4,cell5:

**ABC**,DEF,GHI,  ,    ,

row(2) cell1, cell2, cell3,cell4,cell5:

ZZZ,YEU,   ,   ,

Thank you for your help in advance!

Upvotes: 1

Views: 582

Answers (4)

PermaNoob
PermaNoob

Reputation: 869

Try this:

Sub stack_overflow()
Dim lngLastRow As Long
Dim xNum As Long
Dim xCell As Range
Dim shtFrom As Worksheet
Dim shtTo As Worksheet
Dim lngColCount As Long

'Change the two lines below this to change which sheets you're working with
Set shtFrom = ActiveWorkbook.Sheets(2)
Set shtTo = ActiveWorkbook.Sheets(1)

lngLastRow = shtFrom.Cells.Find(What:="*", After:=Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False).Row

For xNum = 1 To lngLastRow
    lngColCount = 1
    For Each xCell In shtFrom.Range("A" & xNum & ":E" & xNum)
        If xCell.Value <> "" Then
            If shtTo.Range("A" & xNum & ":E" & xNum).Find(What:=xCell.Value, LookIn:=xlValues, Lookat:=xlWhole) Is Nothing Then
                shtTo.Cells(xNum, lngColCount).Value = xCell.Value
                lngColCount = lngColCount + 1
            End If
        End If
    Next xCell
Next xNum

End Sub

Upvotes: 1

mei84
mei84

Reputation: 124

You can try below approach also...

Public Sub remove_blank()

Dim arrayValue() As Variant

ThisWorkbook.Sheets("Sheet1").Activate     ' Sheet1 has the data with blanks
arrayValue = range("A1:H2")                ' Range where the data present...

Dim i As Long
Dim j As Long

Dim x As Integer: x = 1
Dim y As Integer: y = 1

For i = 1 To UBound(arrayValue, 1)
    For j = 1 To UBound(arrayValue, 2)
        Dim sStr As String: sStr = arrayValue(i, j)
        If (Len(Trim(sStr)) <> 0) Then
            ThisWorkbook.Sheets("Sheet2").Cells(x, y).Value = sStr  ' Sheet2 is the destination
            y = y + 1
        End If
     Next j
     x = x + 1
     y = 1
Next i
End Sub

Upvotes: 1

user4039065
user4039065

Reputation:

You are going to have to provide some string manipulation after collecting the values from each row in order to remove the blanks.

Sub contract_and_copy()
    Dim rw As Long, lr As Long, lc As Long, ws As Worksheet
    Dim sVALs As String, vVALs As Variant
    Set ws = Sheets("Sheet1")
    With Sheets("Sheet2")
        lr = .Cells.Find(what:=Chr(42), after:=.Cells(1, 1), SearchDirection:=xlPrevious).Row
        For rw = 1 To lr
            If CBool(Application.CountA(Rows(rw))) Then
                vVALs = .Cells(rw, 1).Resize(1, .Cells(rw, Columns.Count).End(xlToLeft).Column).Value
                sVALs = ChrW(8203) & Join(Application.Index(vVALs, 1, 0), ChrW(8203)) & ChrW(8203)
                Do While CBool(InStr(1, sVALs, ChrW(8203) & ChrW(8203)))
                    sVALs = Replace(sVALs, ChrW(8203) & ChrW(8203), ChrW(8203))
                Loop
                sVALs = Mid(sVALs, 2, Len(sVALs) - 2)
                vVALs = Split(sVALs, ChrW(8203))
                ws.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, UBound(vVALs) + 1) = vVALs
            End If
        Next rw
        'Debug.Print lr
    End With
End Sub

I've used a zero-length space as the delimiter as it is usually unlikely to be a part of a user's data.

Upvotes: 1

manu
manu

Reputation: 942

I found it:

Sub M()
    lastrow = Sheets("Sheet2").Range("A1").SpecialCells(xlCellTypeLastCell).Row
    For i = 1 To lastrow
        Sheets("Sheet2").Range("A" & i & ": M" & i).Copy Sheets("Sheet1").Range("A" & i) ' Change Column M as required
        Sheets("Sheet1").Range("A" & i & ": M" & i).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
    Next
End Sub

Upvotes: 1

Related Questions