从范围复制并过去到下一个空单元格中的另一个工作表中

Question

我想要一些启动VBA代码的提示：

我有两张。 sheet（2）的每一行在每个单元格中都有文本，但是在它们之间可以有一些空单元格。 我的目标是将工作表（2）的第1行从A1复制到E1，然后将其复制到工作表（1）的第1行，但它们之间没有空单元格。

我编辑帖子是因为我没有考虑过这一重要细节。 我想删除同一行中的所有重复项，但保留第一个条目。

并重复该操作，直到最后一行。

数据示例：

工作表（2）：第1行cell1，cell2，cell3，cell4，cell5：

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

第（2）个cell1，cell2，cell3，cell4，cell5：

ZZZ,  ,   ,   ,YEU

预期结果：工作表（1）：第1行cell1，cell2，cell3，cell4，cell5：

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

第（2）个cell1，cell2，cell3，cell4，cell5：

ZZZ,YEU,   ,   ,

提前谢谢你的帮助！

Answer 1

我找到了：

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

Answer 2

尝试这个：

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

Answer 3

从每一行收集值之后，您将必须提供一些字符串操作以删除空格。

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

我使用零长度的空格作为分隔符，因为它通常不太可能成为用户数据的一部分。

Answer 4

您也可以尝试以下方法...

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