'Conditional move loop - VBA excel
I just learned to use VBA in excel, I have a spreadsheet as shown,
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.
-----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.
Screenshot of column B40: B51
The loop I want will return the result as shown below.
Solution 1:[1]
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
Sources
This article follows the attribution requirements of Stack Overflow and is licensed under CC BY-SA 3.0.
Source: Stack Overflow
Solution | Source |
---|---|
Solution 1 |