vbaでデータを移動

Question

私は列F、G、H、およびIでデータを受け取りました。すべてを列Eに入れ、複製と空白セルを取り出す必要があります。私はこれまでのコードは動作しますが、それらはすべて同じ行に配置され、適切な行にそれらを保持しません。私は彼らが現在いる同じ行にとどまるが、もう一方の列に転記する必要がある。これはこれまで私が持っているものです：

Sub Sample() 

    Dim ws As Worksheet 
    Dim LastRow As Long, lastCol As Long, i As Long 
    Dim Rng As Range, aCell As Range, delRange As Range '<~~ Added This 
    Dim MyCol As New Collection 

    ~~> Change this to the relevant sheet name 
    Set ws = Sheets("Sheet1") 

    With ws 
     '~~> Get all the blank cells 
     Set delRange = .Cells.SpecialCells(xlCellTypeBlanks) '<~~ Added This 

     '~~> Delete the blank cells 
     If Not delRange Is Nothing Then delRange.Delete '<~~ Added This 

     LastRow = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByRows, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Row 

     lastCol = .Cells.Find(What:="*", After:=.Range("A1"), _ 
     Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, _ 
     SearchDirection:=xlPrevious, MatchCase:=False).Column 

     Set Rng = .Range("A1:" & Split(.Cells(, lastCol).Address, "$")(1) & LastRow) 

     'Debug.Print Rng.Address 
     For Each aCell In Rng 
      If Not Len(Trim(aCell.Value)) = 0 Then 
       On Error Resume Next 
       MyCol.Add aCell.Value, """" & aCell.Value & """" 
       On Error GoTo 0 
      End If 
     Next 

     .Cells.ClearContents 

     For i = 1 To MyCol.Count 
      .Range("A" & i).Value = MyCol.Item(i) 
     Next i 

     '~~> OPTIONAL (In Case you want to sort the data) 
     .Columns(1).Sort Key1:=.Range("A1"), Order1:=xlAscending, Header:=xlGuess, _ 
     OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ 
     DataOption1:=xlSortNormal 
    End With 

End Sub 

Answer 1

これを試してください。

Sub CopyThingy() 

Dim wb As Workbook 
Dim ws As Worksheet 
Dim lCount As Long 
Dim lCountMax As Long 
Dim lECol As Long 
Dim lsourceCol As Long 

    lECol = 5 '* E column 
    Set wb = ThisWorkbook 
    Set ws = wb.Sheets(1) '*Your Sheet 

    lCountMax = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row 
    lsourceCol = 6 
    lCount = lCountMax 

    Do While lCount > 1 

     If ws.Cells(lCount, lsourceCol) <> "" Then 
      ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value 
     End If 
     lCount = lCount - 1 

    Loop 

    lCountMax = ws.Cells(ws.Rows.Count, "G").End(xlUp).Row 
    lsourceCol = 7 
    lCount = lCountMax 

    Do While lCount > 1 

     If ws.Cells(lCount, lsourceCol) <> "" Then 
      ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value 
     End If 
     lCount = lCount - 1 

    Loop 

    lCountMax = ws.Cells(ws.Rows.Count, "H").End(xlUp).Row 
    lsourceCol = 8 
    lCount = lCountMax 

    Do While lCount > 1 

     If ws.Cells(lCount, lsourceCol) <> "" Then 
      ws.Cells(lCount, lECol).Value = ws.Cells(lCount, lsourceCol).Value 
     End If 
     lCount = lCount - 1 

    Loop 

End Sub