Copy and Transpose Looping Macro

[morky11]

Hi there

I apologise for being such a newb but I have what I think is a simple question, but I just can't seem to find the answer.
I have a spreadsheet that users enter in part numbers and then buyer ID's associated to the part. I have a formula which takes those entries and creates the following single cell (D2).

<TABLE style="WIDTH: 428pt; BORDER-COLLAPSE: collapse" cellSpacing=0 cellPadding=0 width=571 border=0 x:str><COLGROUP><COL style="WIDTH: 428pt; mso-width-source: userset; mso-width-alt: 20882" width=571><TBODY><TR style="HEIGHT: 12.75pt" height=17><TD class=xl26 style="BORDER-RIGHT: #e0dfe3; BORDER-TOP: #e0dfe3; BORDER-LEFT: #e0dfe3; WIDTH: 428pt; BORDER-BOTTOM: #e0dfe3; HEIGHT: 12.75pt; BACKGROUND-COLOR: lime" width=571 height=17>PPRCHGB1234567 BYID=0666 =</TD></TR></TBODY></TABLE>

Essentially I need to copy that cell but change the 'PPRCHGB' to 'PRTCHGB' and then copy it in the row underneath. The end result should look like this:

PPRCHGB1234567 BYID=0666 =<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
PRTCHGB1234567 BYID=0666 =

Here is my rudimentary solution.
I have created a cell next to the one that creates the first result but changes the 'PPRCHGB' to 'PRTCHGB' (E2). Then I have created a macro that takes both cells and transposes them onto another sheet.

Sub test2()

Range("D2:E2").Select
Selection.Copy
Sheets("Sheet1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
End Sub

This seems to work ok, but I can't work out how to get it to repeat the action for each row that contains data ie D3:E3, D4:E4, D5:E5 etc etc.

Once I can get that working, the next step would be that a text file is created from the resulted spreadsheet, which can be uploaded to make multiple changes to our system.

Am I going about this the right way, is there a less complicated solution?

Thanks in advance
Morky

 

[rs2k]

Try this, it may help you get started;

Sub test2()

Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Range("D2:E2").Select
    Range(Selection, Selection.End(xlDown)).Copy
    Sheets("Sheet4").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues
    
    Columns("A:B").Select
    Selection.Copy
    Sheets.Add.Name = "Text File"
    Selection.PasteSpecial Paste:=xlPasteValues
    Application.CutCopyMode = False
    Sheets("Text File").Move
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\Column B.txt", FileFormat:= _
        xlText, CreateBackup:=False
    ActiveWindow.Close
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
End Sub

HTH
Colin

 

[morky11]

Thanks Colin

Works a treat! Except that I need the two cells that are side by side to paste underneath each other so that the resulting text file is only one column not two. Make sense?

Morky

 

[morky11]

Ok so here is what I came up with:

Sub test2()
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Sheet4").Visible = True
Range("D2:E2").Select
Range(Selection, Selection.End(xlDown)).Copy
Sheets("Sheet4").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues

Columns(1).Insert
r = 0
For Each RowNbr In Range("B1", Range("B65535").End(xlUp))
For Each RowItem In Range(RowNbr, Range("IV" & RowNbr.Row).End(xlToLeft))
r = r + 1
Cells(r, 1) = RowItem
Next RowItem
Next RowNbr

Columns("A").Select
Selection.Copy
Sheets.Add.Name = "Text File"
Selection.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Sheets("Text File").Move
ActiveWorkbook.SaveAs Filename:= _
"C:\Documents and Settings\" & Environ("USERNAME") & "\Desktop\Column B.txt", FileFormat:= _
xlText, CreateBackup:=False
ActiveWindow.Close

Cells.Select
Selection.Clear
ActiveWindow.SelectedSheets.Visible = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Your Fastload has been created and saved. Please proceed with upload to CONTROL"

End Sub

Is this looking ok, does it need to be tidied up some?

Also, can anyone help me ensure that the file name is in the following format 'userinitialsdate' i.e. js190210.txt?

Thanks again

 

[ravishankar]

Hi
try these codes

dim filename as string
Filename = Application.UserName & " " & Day(Date) & "-" & Month(Date) & "-" & Year(Date) & ".txt"
MsgBox Filename

ravi

 

[morky11]

Thanks Ravi

Where exactly should I put that code within my existing code?

Morky

 

[morky11]

also, any ideas on how to get the users initials in the filename?