Results 1 to 5 of 5
  1. #1
    2 Star Lounger
    Join Date
    Jun 2003
    Location
    New Jersey
    Posts
    103
    Thanks
    6
    Thanked 0 Times in 0 Posts

    Excel Macro (Excel 2000)

    Can anyone help me with a macro?

    I have data that looks like this:

    EmpID Name Salary Effective Date
    234 John Doe 30,000 4/16/2004
    234 John Doe 28,000 3/12/2003

    But I'd like to convert the data as follows for each employee. Emp ID is the unique key.
    EmpID Name salary Effective date salary Effective Date
    234 John Doe 30,000 4/16/2004 28,000 3/12/2003

    Any help would be greatly appreciated!

  2. #2
    Plutonium Lounger
    Join Date
    Mar 2002
    Posts
    84,353
    Thanks
    0
    Thanked 29 Times in 29 Posts

    Re: Excel Macro (Excel 2000)

    Try this (and read notes below):

    Sub Transfer()
    Dim wshSource As Worksheet
    Dim wshTarget As Worksheet
    Dim lngEmpID As Long
    Dim lngSourceRow As Long
    Dim lngTargetRow As Long
    Dim lngTargetCol As Long
    Dim lngMaxCol As Long
    Set wshSource = Worksheets("Sheet1")
    Set wshTarget = Worksheets.Add
    wshSource.Range("A1:B1").Copy _
    Destination:=wshTarget.Range("A1:B1")
    lngSourceRow = 2
    lngTargetRow = 1
    Do While wshSource.Cells(lngSourceRow, 1) <> ""
    If wshSource.Cells(lngSourceRow, 1) <> lngEmpID Then
    lngEmpID = wshSource.Cells(lngSourceRow, 1)
    lngTargetRow = lngTargetRow + 1
    lngTargetCol = 1
    wshSource.Cells(lngSourceRow, 1).Resize(1, 2).Copy _
    Destination:=wshTarget.Cells(lngTargetRow, lngTargetCol)
    Else
    lngTargetCol = lngTargetCol + 2
    If lngTargetCol > lngMaxCol Then
    lngMaxCol = lngTargetCol
    End If
    wshSource.Cells(lngSourceRow, 3).Resize(1, 2).Copy _
    Destination:=wshTarget.Cells(lngTargetRow, lngTargetCol)
    End If
    lngSourceRow = lngSourceRow + 1
    Loop
    wshSource.Range("C11").Copy _
    Destination:=wshTarget.Range("C1").Resize(1, lngTargetCol - 1)
    wshTarget.Range("A1").CurrentRegion.Columns.AutoFi t
    Set wshTarget = Nothing
    Set wshSource = Nothing
    End Sub

    Notes:
    - Adapt the name Sheet1 of the worksheet containing the original data to your situation.
    - I have assumed that the data begin in cell A1.

  3. #3
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Excel Macro (Excel 2000)

    See if this does what you want:

    <pre>Public Sub CombineRows()
    Dim I As Long, lMaxRows As Long, lMaxCol As Long
    Dim oRng As Range
    lMaxRows = ActiveSheet.Range("B65536").End(xlUp).Row - 1
    Set oRng = ActiveSheet.Range("A1", Range("D1").Offset(lMaxRows))
    oRng.Sort Key1:=ActiveSheet.Range("B1"), Order1:=xlAscending, _
    Key2:=ActiveSheet.Range("D1"), Order2:=xlDescending
    For I = lMaxRows To 1 Step -1
    If ActiveSheet.Range("B1").Offset(I, 0) = ActiveSheet.Range("B1").Offset(I - 1, 0) Then
    lMaxCol = ActiveSheet.Range("IV1").Offset(I - 1, 0).End(xlToLeft).Column
    Range(ActiveSheet.Range("C1").Offset(I, 0), ActiveSheet.Range("IV1").Offset(I, 0).End(xlToLeft)).Copy
    ActiveSheet.Paste Destination:=Range("A1").Offset(I - 1, lMaxCol)
    ActiveSheet.Range("A1").Offset(I, 0).EntireRow.Delete
    End If
    Next I
    End Sub
    </pre>



    The macro assumes that the data is on the active sheet, and that it starts in row 1 (ie. there are no title rows). If these are not correct, the macro will need to be modified.
    Legare Coleman

  4. #4
    2 Star Lounger
    Join Date
    Jun 2003
    Location
    New Jersey
    Posts
    103
    Thanks
    6
    Thanked 0 Times in 0 Posts

    Re: Excel Macro (Excel 2000)

    Hello Legare,

    I pasted the macro but it came over all on one row. So everytime I run the macro it gives me an error message. I tried to organize it but with no prevail. Please see the macro below. What can be wrong?

    Public Sub CombineRows()
    Dim I As Long, lMaxRows As Long, lMaxCol As LongDim
    oRng As Range
    lMaxRows = ActiveSheet.Range("B65536").End(xlUp).Row - 1
    Set oRng = ActiveSheet.Range("A1", Range("D1").Offset(lMaxRows))
    oRng.Sort Key1:=ActiveSheet.Range("B1"), Order1:=xlAscending, _
    Key2:=ActiveSheet.Range("D1"), Order2:=xlDescending
    For I = lMaxRows To 1 Step -1
    If ActiveSheet.Range("B1").Offset(I, 0) = ActiveSheet.Range("B1").Offset(I - 1, 0) Then lMaxCol = ActiveSheet.Range("IV1").Offset(I - 1, 0).End(xlToLeft).Column
    Range(ActiveSheet.Range("C1").Offset(I, 0), ActiveSheet.Range("IV1").Offset(I, 0).End(xlToLeft)).Copy ActiveSheet.Paste
    Destination:=Range("A1").Offset(I - 1, lMaxCol)
    ActiveSheet.Range("A1").Offset(I, 0).EntireRow.Delete
    End If
    Next I
    End Sub

  5. #5
    Uranium Lounger
    Join Date
    Jan 2001
    Location
    South Carolina, USA
    Posts
    7,295
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Excel Macro (Excel 2000)

    That is an unfortunate side effect of the Lounge. Here's how to get around that problem:

    1- Copy the macro from my first post.

    2- Open Windows WordPad (I have it in my quick start bar for just this reason).

    3- Paste the macro into WordPad.

    4- Select the macro in WordPad and copy it.

    5- Close WordPad (Don't save anything).

    6- Paste the macro into Excel.

    It should now look right and work.
    Legare Coleman

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •