Conditional move loop - VBA excel

user_18568999 0
Viewed 128

I just learned to use VBA in excel, I have a spreadsheet as shown,

enter image description here

I have columns from B1:B12 containing content to search and move, I want to build code to search Move the characters in the range C13:AD31 to the same row in the range from C1:AD12. For example, in the area C13:AD31, there is a subregion E14:J14 containing the content "Vn" which is the same as B2, then move (cut + paste) E14:J14 to E2:J2, and continue the loop until moved all the characters in the area C13:AD31 (in other words A13:AD31 only left all empty cells). The loop I want will return the result as shown below.

enter image description here

-----a-----++++

(Update 3/31/2022) Thank you VBasic2008 your code is amazing, sorry to bother you again, indeed I can't understand every single content in your code, so I still can't customize the code to fit my generated data. Currently my excel sheet has generated 169 lines.

This time I have columns from B40:B51 and B127:B138 containing content to search and move.

enter image description here

Screenshot of column B40: B51 enter image description here

The loop I want will return the result as shown below.

enter image description here

vba excel
1 Answers

Update Missing Data

Option Explicit

Sub UpdateData()
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
    Dim rg As Range
    With ThisWorkbook.Worksheets("Sheet1").UsedRange
        Set rg = .Resize(, .Columns.Count - 1).Offset(, 1)
    End With
    
    Dim cell As Range
    Set cell = rg.Columns(1).Find("*", , xlValues, , , xlPrevious)
    Dim drCount As Long: drCount = cell.Row - rg.Row + 1
    Dim cCount As Long:  cCount = rg.Columns.Count - 1
    
    Dim lrg As Range: Set lrg = rg.Cells(1).Resize(drCount) ' Lookup
    Dim drg As Range: Set drg = lrg.Resize(, cCount).Offset(, 1) ' Destination
    
    ' Source
    Dim srCount As Long: srCount = rg.Row + rg.Rows.Count - cell.Row - 1
    Dim srg As Range: Set srg = rg.Resize(srCount, cCount).Offset(drCount, 1)
    
    Debug.Print lrg.Address, drg.Address, srg.Address, cCount
    
    Application.ScreenUpdating = False
    
    Dim srrg As Range
    Dim sValue As Variant
    Dim drIndex As Variant
    Dim c As Long
    
    For Each srrg In srg.Rows
        If Application.CountBlank(srrg) < cCount Then
            For c = 1 To cCount
                sValue = srrg.Cells(c).Value
                If Not IsError(sValue) Then
                    If Len(sValue) > 0 Then
                        drIndex = Application.Match(sValue, lrg, 0)
                        If IsNumeric(drIndex) Then
                            srrg.Cells(c).Copy drg.Cells(drIndex, c)
                        End If
                    End If
                End If
            Next c
        End If
    Next srrg
    
    Application.ScreenUpdating = True
    
    MsgBox "Data updated.", vbInformation
    
End Sub
user_98140690
Related