Loop to find a cell, then copy offset paste

[mr.alexander]

Hello. Really new at VB in excel, and would love any help woth a work assignment.

I have a data sheet with employee information. Only one column. It prefixes information with codes, but keeps it in the same cell. I want to move data of certain types into their own columns, but the amount of data is variable, so I cannot simply move every Nth cell, etc.

i.e.

Employee#1
200 Firstname Lastname
204 99999999 (Employee ID)
G38 00005000 (i.e. Pension Deduction)
H38 00007580 (i.e. Benefits Deduction)
X96 00012099 (i.e. Staff Club Deduction)
Employee#2
200 Firstname Lastname
204 99999998
G38 00000775
X96 00001000

So you see some employees may have different codes altogether. But I know that I want all the cells that start with 200 to be offset (-1,1), and all the cells that start with 204 to be offset (-1,2), and so on so that basically I end up with columns of info instead of a one column list.

I have been reading and studying other peoples' macros, and am just starting to grasp the basic. When I wrote my own to accomplish this, I put this together, which doesn't work. But I don't know enough to know what I don't know.

 
Sub Macro1()
 
Dim x As Range
 
 
Do
Set x = Columns(1).Find("*200 *")
If x Is Nothing Then Exit Do
x.Select
Selection.Cut
ActiveCell.Offset(-1, 1).Select
Selection.PasteSpecial
Loop
End Sub

What I have so far finds what I am looking for, copies it but the paste fails.

[shg]

Welcome to the forum.

Try this:

    Dim r       As Range

    Do
        Set r = Columns(1).Find("200 *")
        If r Is Nothing Then Exit Do
        r.Cut Destination:=r.Offset(-1, 1)
    Loop

[Strugglin]

Hi Mr Alexander

Here is a basic version that will give you an idea.

What you need to remember for this to work correctly is that every employee does not have any empty cells, e.g. even if they dont have a staff discount that cell must still contain the search prefix number so that all data will tally up with the right Staff member.


Regards

[solnajeff]

Hi

Here is another for you to try, the destination for all is on the "200" line for convenience but can be placed anywhere.

Regards

Jeff

[rylo]

Hi

Yet another approach. This one will build a list of the headings from the data, and split it out.

Sub aaa()
  Dim nodupes As New Collection
  On Error Resume Next
  For Each ce In Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Mid(ce.Value, 4, 1) = " " Then
      nodupes.Add Item:=CStr(Left(ce.Value, 4)), key:=CStr(Left(ce.Value, 4))
    End If
  Next ce
  On Error GoTo 0
  Range("A1").EntireRow.Insert
  Rows("1:1").NumberFormat = "@"
  Range("A1").Value = "Employee Number"
  For i = 1 To nodupes.Count
    Range("A1").Offset(0, i).Value = nodupes(i)
  Next i
  For Each ce In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    If Mid(ce.Value, 4, 1) = " " Then
      outcol = WorksheetFunction.Match(Left(ce.Value, 4), Rows("1:1"), 0)
      Cells(outrow, outcol).Value = ce.Value
      ce.ClearContents
    Else
      outrow = ce.Row
    End If
  Next ce
  Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

rylo

[mr.alexander]

Wow. I am overwhelmed at the knowledgable help that I received here! Thank you so much.

shg : your post technically answered my question and it was really helpful to see what I was doing wrong. But once I got it going, I realized that what I had started writing was not going to do the trick.

strugllin, solnajeff and rylo : you discerned what I was trying to accomplish, and showed me some great codes.

With the type of data I am working with and the type of report that I need to produce, SolnaJeff's transpose macro would work best for my particular needs. But I am struggling a bit to modify it to my needs.

I have modified the sample transpose sheet and included sample data that i am working on. I have anonymized the data. What I am attempting to do is to include the employee number. It is hidden in the data and I am using a mid function to extrapolate, but I am using the wrong logic and this addition is being ignored. The employee number is the 4 digits starting at the 15th character in the rows that begin with "#", which are always above the "200" row. The 200 row is d, which led me to try this logic:

Let eeid = Mid(Cells(d - 1), 15, 4)
Let Cells(d, 2).Value = eeid

Can someone tell me what it is that I am misunderstanding?

Thank you!

[mr.alexander]

Ok, I played with it until I found the answer, and I think I have it now.

Here is the final product, and it seems to work very well.

It strips out the codes I don't need, then adds the column headers, then does the transpose feature that you gave to me, then deletes the source column and blank rows. Thank you all for your help. With a few more minor tweaks, this macro will save me an hour a week!

Sub PEPP_Report()

Dim rng As Range, cell As Range, del As Range, eeid As String, namefull As String, fname As String, lname As String, c, d As Integer
Dim strCellValue As String

Set rng = Intersect(Range("A:A"), ActiveSheet.UsedRange)
For Each cell In rng

strCellValue = (cell.Value)
If InStr(strCellValue, "#") = 0 Then
If InStr(strCellValue, "200 ") = 0 Then
If InStr(strCellValue, "204 ") = 0 Then
If InStr(strCellValue, "G38") = 0 Then
If InStr(strCellValue, "H38") = 0 Then
If InStr(strCellValue, "Y38") = 0 Then
If InStr(strCellValue, "X38") = 0 Then
If del Is Nothing Then
       Set del = cell
       Else: Set del = Union(del, cell)
    End If
    End If
    End If
    End If
    End If
    End If
    End If
    End If
  Next cell
  On Error Resume Next
  del.EntireRow.Delete
  
    Do
        Set rng = Columns(1).Find("*205 *")
        If rng Is Nothing Then Exit Do
        rng.EntireRow.Delete
    Loop
    


Range("A1").EntireRow.Insert
Range("B1").Value = "Employee #"
Range("C1").Value = "Name"
Range("D1").Value = "SIN"
Range("E1").Value = "CURR EE PEPP"
Range("F1").Value = "YTD EE PEPP"
Range("G1").Value = "CURR ER PEPP"
Range("H1").Value = "YTD ER PEPP"

With Sheets("sheet1").Columns(1)
    Set c = .Find("#", LookIn:=xlValues)
    If Not c Is Nothing Then
        firstaddress = c.Address
        Do
            Let d = c.Row
            Let eeid = Mid(Cells(d, 1), 15, 4)
            Let Cells(d, 2).Value = eeid
           Do
            Let d = d + 1
            'Let namefull = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            'Let Cells(d, 3).Value = namefull
                  
            
            Select Case Left(Cells(d, 1), 3)
            Case Is = "200"
            Let Cells(c.Row, 3).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            Case Is = "204"
            Let Cells(c.Row, 4).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            Case Is = "X38"
            Let Cells(c.Row, 5).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            Case Is = "Y38"
            Let Cells(c.Row, 6).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            Case Is = "G38"
            Let Cells(c.Row, 7).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            Case Is = "H38"
            Let Cells(c.Row, 8).Value = Right(Cells(d, 1), Len(Cells(d, 1)) - 4)
            End Select
           Loop Until Left(Cells(d, 1), 1) = "#" Or Cells(d, 1).Value = ""
            
            Set c = .FindNext(c)
        Loop While Not c Is Nothing And c.Address <> firstaddress
    End If
End With

Columns("A:A").Select
Selection.Delete

Dim x As Long

With ActiveSheet
    For x = .Cells.SpecialCells(xlCellTypeLastCell).Row _
        To 1 Step -1
        If WorksheetFunction.CountA(.Rows(x)) = 0 Then
            ActiveSheet.Rows(x).Delete
        End If
    Next
End With
    
    
    
End Sub

Thanks to all!

[Leith Ross]

Your post does not comply with Rule 9 of our Forum RULES. If you solve a problem yourself before anyone else has responded, please take a moment to describe your solution, chances are some other member will benefit. And please never edit a thread in which someone else has responded.

How to mark a thread Solved
Go to the first post
Click edit
Click Go Advanced
Just below the word Title you will see a dropdown with the word No prefix.
Change to Solved
Click Save

[wacholec1985]

hello, i need macro to find value in column A(level) (in next column are values too), after find this value, cut all data from this row and move right to defined offset.

eg line with level:

0 not move
1 not move
2 move right one position all data with this line
3 move right two position all data with this line
4 move right three position all data with this line
5 move right four position all data with this line




I have to make tree structure

my macro is:

Sub Macro1()
 
Dim x As Range
 
 
Do
Set x = Columns(1).Find("2*")
If x Is Nothing Then Exit Do
x.Select
Selection.Cut
ActiveCell.Offset(0, 1).Select
ActiveSheet.Paste
Loop

Do
Set x = Columns(1).Find("3*")
If x Is Nothing Then Exit Do

Selection.Cut
ActiveCell.Offset(0, 2).Select
ActiveSheet.Paste
Loop

Do
Set x = Columns(1).Find("4*")
If x Is Nothing Then Exit Do
x.Select
Selection.Cut
ActiveCell.Offset(0, 3).Select
ActiveSheet.Paste
Loop

Do
Set x = Columns(1).Find("5*")
If x Is Nothing Then Exit Do
x.Select
Selection.Cut
ActiveCell.Offset(0, 4).Select
ActiveSheet.Paste
Loop



End Sub

but move only one cell right (i need all data from line move right to define position)
please help

[arlu1201]

Wacholec1985,

Unfortunately you need to post your question in a new thread, it's against the forum rules to post a question in the thread of another user. If you create your own thread, any advice will be tailored to your situation so you should include a description of what you've done and are trying to do. Also, if you feel that this thread is particularly relevant to what you are trying to do, you can surely include a link to it in your new thread.

Also,

I have added code tags to your post. As per forum rule 3, you need to use them whenever you put any code in your post. Please add them in future. If you need more information on how to use them, check my signature below this post.