从一个范围复制，并在另一个工作表中在一行中的下一个空单元格中复制
我想有一些技巧来启动一个VBA代码：
我有2张。 工作表（2）的每一行在每个单元格中都有文本，但在它们之间可以有一些空单元格。 我的目标是从表（2）的行1开始，从A1复制到E1，并在表单（1）行1中复制，但在它们之间没有空单元格。
我编辑我的post，因为我没有想过这个重要的细节。 我想删除在同一行中的任何重复，但保留第一个条目。
并重复操作，直到最后一行。
数据例：
工作表（2）：row1 cell1，cell2，cell3，cell4，cell5：
**ABC**, ,DEF,**ABC**,GHI row（2）cell1，cell2，cell3，cell4，cell5：
ZZZ, , , ,YEU
预期结果：工作表（1）：row1 cell1，cell2，cell3，cell4，cell5：
**ABC**,DEF,GHI, , ,
row（2）cell1，cell2，cell3，cell4，cell5：
ZZZ,YEU, , ,
提前谢谢你的帮助！
尝试这个：
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
我find了：
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
你将不得不提供一些string操作后收集每行的值，以消除空白。
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
我用零长度的空格作为分隔符，因为它通常不太可能成为用户数据的一部分。
你可以尝试下面的方法也…
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