Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

  • Congratulations derfloh on being selected by the Tek-Tips community for having the most helpful posts in the forums last week. Way to Go!

Mental block on VBA 2

Status
Not open for further replies.

Walter349

Technical User
Aug 16, 2002
250
BE
I am completely blocked on this one.

I need to copy a range of cells, A1,B1,C1, A2, B2, C2 etc. etc. Until a blank row, and then put them into a new workbook.

All straight forward enough so far.

But I also need to concatenate the contents of all B column cells, to paste in a single cell in the destination workbook with the other copied cells.

Any pointers on this would be appreciated

'If at first you don't succeed, then your hammer is below specifications'
 
For concatenation, try replacing your last bit of code with this:
Code:
Worksheets("Sheet2").Select
    'Check for next free row for data and position cursor
    X = Cells(Rows.Count, 1).End(xlUp).Row
    Y = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    
    For i = 1 To lLastRow
        For j = 1 To 2
            ActiveCell(Y, 1).Value = ActiveCell(Y, 1).Value + Ary(i, j)
        Next j
    Next i
When you have the code doing what you need then post back and I am sure we can help you tidy it up.

Gavin
 
OK I had a go at tidying things up a bit. Note how this code does not rely on Select or Activate.
Code:
Public Sub Transfer_Data()
    Dim WrkBk As String
    Dim X As Long
    Dim Y As Long
    Dim lLastRow As Integer
    Dim Ary() As String
    Dim iCount As Integer
    Dim wbkTarget As Workbook
    Dim wbkSource As Workbook
    
Application.ScreenUpdating = False
Application.EnableEvents = False

'Destination workbook
WrkBk = "T:\Project Documentation\Test1A\Ctrak.xls"
    
Set wbkSource = ActiveWorkbook
Set wbkTarget = Workbooks.Open(WrkBk)

'Check for next free row for data and position cursor
Y = wbkTarget.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row + 1
    
'Copy data to worksheet
With wbkTarget
    .Worksheets("Sheet1").Cells(Y, 1).Value = _
       wbkSource.ActiveSheet.Range("A1").Value
    .Worksheets("Sheet1").Cells(Y, 2).Value = _
       wbkSource.ActiveSheet.Range("B6").Value
    .Worksheets("Sheet1").Cells(Y, 3).Value = _
        wbkSource.ActiveSheet.Range("D6").Value
    .Worksheets("Sheet1").Cells(Y, 4).Value = _
        wbkSource.ActiveSheet.Range("C8").Value
    .Worksheets("Sheet1").Cells(Y, 6).Value = _
        wbkSource.ActiveSheet.Range("G11").Value
    .Worksheets("Sheet1").Cells(Y, 5).Value = _
        wbkSource.ActiveSheet.Range("A15").Value
        
    'Concatenated values (from cells A16 & C16 to lastrow)
    'find last row in source workbook
    lLastRow = wbkSource.Worksheets("Model").Cells(Rows.Count, "A").End(xlUp).Row
    With .Worksheets("Sheet1").Cells(Y, 7)
        For iCount = 16 To lLastRow
            .Value = .Value + wbkSource.Worksheets("Model").Cells(iCount, 1).Value
            .Value = .Value + wbkSource.Worksheets("Model").Cells(iCount, 3).Value
        Next iCount
    End With
End With
    
    Erase Ary
End Sub

Gavin
 
Gavin,

Thanks for all the help. I see where I was going wrong on the array, now that you have waved it in front of me. Talk about digging yourself a hole. frankly the thing was starting to drive me nuts.

From the script you that you have made more efficent, I can see that my thinking re coding is a bit old fashioned, I am going to have to get some up-to-date formal grounding this.

I have tried your re-vamped script and it does exactly what I wanted.( was trying to achive, Badly..)

Again thanks to you and Skip for your patience and help.


'If at first you don't succeed, then your hammer is below specifications'
 
I am going to have to get some up-to-date formal grounding this.
You can learn a lot by watching posts here at Tek-Tips. Also post code here and experts like Skip will help you to improve it.

Gavin
 
Status
Not open for further replies.

Part and Inventory Search

Sponsor

Back
Top