Moving data to other columns using multiple criteria

[zookeepertx]

Hello all!
I hope my title gave SOME idea what I need. I'll attach an example. I'm very sorry for just posting screenshots, but I'm not allowed to download/install the thing to post a workbook because this is my work computer.

Basically, I need to find a value in C that has 20 characters plus a "~" at the end and paste that into R1
Then, before the next instance of that value in C, if there's a number in H (in the workbook, this happens in H18), I need that to go into S1. And the value in C19 needs to go into T1
Any further instances where there's a number in H, that value needs to go into S2 and the corresponding value in C needs to go into T2
This should continue until there's another instance of a value in C that has 20 characters plus a "~" at the end. That long value needs to go into R, below the previous data.

This process should go on to the end of the data in the sheet.

I've color coded the data to (hopefully) make it clearer. Oh, I should say that I've hidden a number of rows in each image because they were to large to upload otherwise.
ORIGINAL DATA

CURRENT RESULT

DESIRED RESULT

EVEN BETTER RESULT

Here's what I have so far, which gives me what I've shown as "Current Result"

Sub DNE()
'JennyD06092023

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .Calculation = xlCalculationManual
    .DisplayAlerts = False
End With

'Find last row with data
lr = Range("A" & Rows.count).End(xlUp).row

DestCol = 18
DestRow = 1
For i = 1 To lr Step 1
    If Len(Cells(i, 3).Value) > 20 And InStr(Cells(i, 3).Value, "~") Then
        Cells(DestRow, DestCol) = Cells(i, 3)
            For m = i To lr Step 1
                If Len(Cells(m, 8).Value) > 12 Then
                    Cells(DestRow, DestCol + 1) = Cells(m, 8)
                    Cells(DestRow, DestCol + 2) = Cells(m + 1, 3)
                    DestRow = DestRow + 1
                End If
            Next m
        DestRow = DestRow + 1
    End If
 
Next i

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlCalculationAutomatic
    .DisplayAlerts = True
End With

End Sub

I'm sure that my problem lies in the line "For m =i to lr Step 1". I need to get that range to refer to the section between the 2 ridiculously large numbers with the "~" in C but can't figure out how to designate the next occurrence of that number.

Please let me know if I've been confusing and I'll try to explain further.
I really hope this is a simple fix because my boss just gave me this project late yesterday and wants it ASAP. I truly thought I could figure it out myself but should have just come here earlier to ask for help.

Thank you for any assistance! This board has never, ever let me down.

Jenny

 

[DanteAmor]

Hi @zookeepertx , I hope you are well.

Try this:

Sub movingdata()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
  
  a = Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 3)
  
  For i = 1 To UBound(a)
    If Len(a(i, 3)) > 20 And Right(a(i, 3), 1) = "~" Then
      For j = i To UBound(a)
        If j > i Then
          If Len(a(j, 3)) > 20 And Right(a(j, 3), 1) = "~" Then
            i = j - 1
            Exit For
          End If
        End If
        If Len(a(j, 8)) > 12 Then
          k = k + 1
          b(k, 1) = a(i, 3)
          b(k, 2) = a(j, 8)
          b(k, 3) = a(j + 1, 3)
        End If
      Next
    End If
  Next
  
  Range("S1").Resize(k, 3).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

 

[zookeepertx]

Hi @zookeepertx , I hope you are well.

Try this:

Sub movingdata()
  Dim a As Variant, b As Variant
  Dim i As Long, j As Long, k As Long
 
  a = Range("A1:H" & Range("A" & Rows.Count).End(xlUp).Row).Value
  ReDim b(1 To UBound(a), 1 To 3)
 
  For i = 1 To UBound(a)
    If Len(a(i, 3)) > 20 And Right(a(i, 3), 1) = "~" Then
      For j = i To UBound(a)
        If j > i Then
          If Len(a(j, 3)) > 20 And Right(a(j, 3), 1) = "~" Then
            i = j - 1
            Exit For
          End If
        End If
        If Len(a(j, 8)) > 12 Then
          k = k + 1
          b(k, 1) = a(i, 3)
          b(k, 2) = a(j, 8)
          b(k, 3) = a(j + 1, 3)
        End If
      Next
    End If
  Next
 
  Range("S1").Resize(k, 3).Value = b
End Sub

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------​

That's perfect! Thank you so much. You're awesome!!
Have a great weekend.

Jenny