Copy data to new workbook and add specific text to each row´s value in a specific column

Question

I am exporting data from one workbook to another workbook to T13:Tlastrow
This data, from column F in my workbook where I run this macro, I want to be put into {nyckel="TEXT HERE";} in column T in the "new" workbook, starting from row 13 (T13).

I am stuck here. So would really appreciate some help/solution. Thanks!

Sub CopyData()
    Dim wkbCurrent As Workbook, wkbNew As Workbook
    Set wkbCurrent = ActiveWorkbook
    Dim valg, c, LastCell As Range
    Set valg = Selection
    Dim wkbPath, wkbFileName, lastrow As String
    Dim LastRowInput As Long
    Dim lrow, rwCount, lastrow2, LastRowInput2 As Long

    Application.ScreenUpdating = False

    ' If nothing is selected in column A
    If Selection.Columns(1).Column = 1 Then

        wkbPath = ActiveWorkbook.Path & "\"
        wkbFileName = Dir(wkbPath & "CIF LISTEN.xlsm")

        Set wkbNew = Workbooks.Open(wkbPath & "CIF LISTEN.xlsm")

        'Application.Run ("'C:\Users\niclas.madsen\Desktop\TEST\CIF LISTEN.xlsm'!DelLastRowData")
        LastRowInput = Cells(Rows.count, "A").End(xlDown).Row

        For Each c In valg.Cells
            lrow = wkbNew.Worksheets(1).Range("B1").Offset(wkbNew.Worksheets(1).Rows.count - 1, 0).End(xlUp).Row + 1

            lastrow2 = Range("A" & Rows.count).End(xlUp).Row
            lastrow3 = Range("T" & Rows.count).End(xlUp).Row

            wkbCurrent.ActiveSheet.Range("E" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("A" & lrow)
            wkbCurrent.ActiveSheet.Range("A" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("B" & lrow)
            wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)
            ' Standard inputs
            wkbNew.Worksheets(1).Range("D13:D" & lastrow2).Value = "Ange referens och period"
            wkbNew.Worksheets(1).Range("E13:E" & lastrow2).Value = "99999002"
            wkbNew.Worksheets(1).Range("G13:G" & lastrow2).Value = "EA"
            wkbNew.Worksheets(1).Range("H13:H" & lastrow2).Value = "2"
            wkbNew.Worksheets(1).Range("M13:M" & lastrow2).Value = "SEK"
            wkbNew.Worksheets(1).Range("N13:N" & lastrow2).Value = "sv_SE"
            wkbNew.Worksheets(1).Range("P13:P" & lastrow2).Value = "TRUE"
            wkbNew.Worksheets(1).Range("Q13:Q" & lastrow2).Value = "TRUE"
            wkbNew.Worksheets(1).Range("S13:S" & lastrow2).Value = "Catalog_extensions"

            'wkbNew.Worksheets(1).Range("T" & lastrow3).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & lastrow3).Value & ";}"
        Next
    ' Trying to get this to work
        LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row

        For i = 0 To LastRowInput2 - 13

            wkbNew.Worksheets(1).Range("T" & 13 + i).Value = "{Nyckelord=" & wkbNew.Worksheets(1).Range("T" & 13 + i).Value & ";}"
        Next i
' END HERE

        ' wkbNew.Close False
        ' Find the number of rows that is copied over
        wkbCurrent.ActiveSheet.Activate
        areaCount = Selection.Areas.count
        If areaCount <= 1 Then
             MsgBox "The selection contains " & Selection.Rows.count & " suppliers."
             ' Write it in A10 in CIF LISTEN
             wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & Selection.Rows.count & " Suppliers Added"
        Else
            i = 1
            For Each A In Selection.Areas
                'MsgBox "Area " & I & " of the selection contains " & _
                    a.Rows.count & " rows."
                i = i + 1
                rwCount = rwCount + A.Rows.count
            Next A
            MsgBox "The selection contains " & rwCount & " suppliers."
            ' Write it in A10 in CIF LISTEN
            wkbNew.Worksheets(1).Range("A10").Value = "COMMENTS: " & rwCount & " Suppliers Added"
        End If

        wkbNew.Worksheets(1).Activate

        Application.ScreenUpdating = True

    Else
        MsgBox "Please select cell(s) in column A", vbCritical, "Error"
        Exit Sub
    End If
End Sub

Can you describe what is happening that is not as required please? If you are getting an error please tell us what error on what line. — Stef Joynson, Mar 31 '15 at 10:09
So when I am trying to run the macro `Trying to get this to work`, it will only change the last cell of T with nyckelord.. — Niclas, Mar 31 '15 at 10:13

score 0 · Answer 1 · answered Mar 31 '15 at 10:32

0

If the code is doing the right action but on the wrong cells, then the problem is in the start and end of the For loop. Your For Loop is going from row '13 + i' where i = 0 (so row 13), to row 13 + LastRowInput2 - 13 (so LastRowInput2). This seems right to me, so the problem must be with the value in LastRowInput2.

You need to correct this line:

LastRowInput2 = wkbNew.Worksheets(1).Range("T" & wkbNew.Sheets("Sheet1").UsedRange.Rows.count + 1).End(xlUp).Row

So that is gives you the correct last row input in your data. There are several approaches to finding the end of data depending on whether there may be blank cells in the middle and other factors. This may be one option:

LastRowInput2 = wkbNew.Worksheets(1).Range("T65000").End(xlUp).Row

Be sure to step through the code and verify that LastRowInput2 is set to the value you expect and then this should work.

answered Mar 31 '15 at 10:32

Stef Joynson

222
3
10

Thank you @stefjoynson but wouldn´t this be time consuming to run through all 65000 rows? – Niclas Mar 31 '15 at 11:09
You're not running through all 65000 rows, .End(xlup) looks upwards from row 65000 and returns the first row above that with any data in it. (i.e. the last row) For other methods of exstablishing the end of the data in a column see this: http://stackoverflow.com/questions/11169445/error-finding-last-used-cell-in-vba – Stef Joynson Mar 31 '15 at 11:16
So I tried to use this and also another method, what is happening is exactly the same. My apologies for the bad explanation. So the new workbook is receiving the imported cells one by one, which means that it will be inserted into the last row and then replaced by the next one on the list. When the import is finished, it adds the nyckelord to all the cells in the column. So basically, all the existed text in T will have added another nyckelord to them and only one cell would have been imported. – Niclas Mar 31 '15 at 11:34
Tried to modify my for next a bit `wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" & wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & ";}"` .. now it is still posting into the last cell, but the nyckelord is not added to the other cells, however, the imported data keeps being replaced by all the time and only the final row of the imported data is left. But with the correct output. – Niclas Mar 31 '15 at 11:39
Maybe it is possible to do an if else statement in the new workbook, so when the data is imported, it will look for lines that contain `{Nyckelord="*";}` and leave those, but if not found then replace that cell´s value with `{Nyckelord="CELL VALUE";}` – Niclas Mar 31 '15 at 12:01
Could you just amend this line: wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow) so that it adds the "{Nyckelord=" etc in as it goes? – Stef Joynson Mar 31 '15 at 12:53
I have tried to, but I cannot get it to work. Could you help with this? – Niclas Mar 31 '15 at 13:37

score 0 · Accepted Answer · answered Mar 31 '15 at 14:07

0

OK Try

wkbNew.Worksheets(1).Range("T" & lrow).Value = "{Nyckelord=" &  wkbCurrent.ActiveSheet.Range("F" & c.Row).Value & "}"

Instead of your line:

wkbCurrent.ActiveSheet.Range("F" & c.Row).Copy Destination:=wkbNew.Worksheets(1).Range("T" & lrow)

And remove the whole block marked 'Trying to get this to work

answered Mar 31 '15 at 14:07

Stef Joynson

222
3
10

Thank you man! Haha I was soooo close myself, but I really appreciate it! :) Just added 2 extra "" before and after the & to make the output correct. – Niclas Mar 31 '15 at 14:27

Copy data to new workbook and add specific text to each row´s value in a specific column

2 Answers2