[VBA] Loop through a range in column A, copy data on the right according to a specific value in the looping range

[raulmadrid]

Hi all,

I am working on a task and need a macro to loop through Column A which contains numbers and copy the data in Columns B & C with a specific number in column A (please see the table below)

Column A	Column B	Column C
1	a	aa
2	b	bb
2	b	bb
2	b	bb
2	b	bb
3	c	cc
3	c	cc

<tbody>
</tbody>

For example, I want to copy data in columns B & C with number 1 in column A and then paste in Columns D & E. Subsequently, the macro will copy data with number 2 then paste in Columns F & G and so forth.

I have found a code that identifies the group with number 2s and copy related data. But this code stops at number 2 only. (Sorry I have googled this code and lost track of where I got it from.)

Sub ChooseRangeWithSpecificDataAndCopy()


   Dim Lrow As Integer
   Dim LColARange As String
   Dim LContinue As Boolean
   
   'Select Sheet1
   Sheets("Sheet1").Select
   Range("A2").Select
   
   'Initialize variables
   LContinue = True
   Lrow = 2
   
   'Loop through all column A values until a blank cell is found or value does not
   ' match cell A2's value
   While LContinue = True
      
      Lrow = Lrow + 1
      LColARange = "A" & CStr(Lrow)
      
      'Found a blank cell, do not continue
      If Len(Range(LColARange).Value) = 0 Then
         LContinue = False
      End If
      
      'Found first occurrence that did not match cell A2's value, do not continue
      If Range("A2").Value <> Range("A" & CStr(Lrow)).Value Then
         LContinue = False
      End If
      
      'Copy data from columns A - C
    Range("B2:C" & CStr(Lrow - 1)).Copy
      Range("E2").Select
      ActiveSheet.Paste
      
   Wend
   
   MsgBox "Copy has completed."
   
End Sub

As this task is urgent and I am not good at VBA, any help to solve this is greatly appreciated.

Looking forward to your replies...

Thank you.

 

[WarPigl3t]

Just an idea popping up in my mind, and I think it would be quicker: can we filter by each unique value in column A then copy visible cells only in B & C?

That is not the hard part. Deciding where data goes in a logical manner without hard coding it is the hard part. In case you don't know what hard coding is... I don't want to create a ton of if statements that say IF the value is equal to 1 then put data in column D and E. That would be extremely tedious and not very effective if you have values in column A that are much higher than just 3 like you have in your dataset and i'm assuming you do. So it needs to be dynamic and not hard coded so that if you put a number in the A column such as 666, then it would still work without having to add code.

 

[ztodd]

Did you not see the solution I posted??

Here it is again -

Function funStuff()
    Dim r As Range
    Set r = [a2]
    While r.Value <> ""
        If Val(r.Value) Then r.Offset(0, 1).Resize(1, 2).Copy r.Offset(0, 2 * r.Value + 1)
        Set r = r.Offset(1)
    Wend
 [COLOR=#333333]End Function
[/COLOR]

 

[WarPigl3t]

I tried that out, but it didn't work for me. I assumed that it was a partial solution or something. I don't know what it does. I'm not familiar with Offset.

 

[raulmadrid]

Did you not see the solution I posted??

Here it is again -

Function funStuff()
    Dim r As Range
    Set r = [a2]
    While r.Value <> ""
        If Val(r.Value) Then r.Offset(0, 1).Resize(1, 2).Copy r.Offset(0, 2 * r.Value + 1)
        Set r = r.Offset(1)
    Wend
 [COLOR=#333333]End Function
[/COLOR]

I see it a function and I guess I need to put it in some code calling it out right? So I don't know what to do with it without a code.

 

[raulmadrid]

That is not the hard part. Deciding where data goes in a logical manner without hard coding it is the hard part. In case you don't know what hard coding is... I don't want to create a ton of if statements that say IF the value is equal to 1 then put data in column D and E. That would be extremely tedious and not very effective if you have values in column A that are much higher than just 3 like you have in your dataset and i'm assuming you do. So it needs to be dynamic and not hard coded so that if you put a number in the A column such as 666, then it would still work without having to add code.

I guess if we use some coding related to filter, it's not hard code as we don't need to go through every value in column A. (We can add a heading line as the filter line)

For example, first we filter 1 then copy visible cells in B & C. Then filter 2 and copy visible cells in B & C again etc.

 

[WarPigl3t]

Alright I'm done.
Here is the dataSet I used.

	A	B	C
1	1	a	aa
2	2	b	bb
3	2	b	bb
4	2	b	bb
5	2	b	bb
6	3	c	cc
7	3	c	cc

<colgroup><col style="width:48pt" span="3" width="64"> </colgroup><tbody>
</tbody>

Here is the output after you run the code.

	A	B	C	D	E	F	G	H	I
1	1	a	aa	a	aa	b	bb	c	cc
2	2	b	bb			b	bb	c	cc
3	2	b	bb			b	bb
4	2	b	bb			b	bb
5	2	b	bb
6	3	c	cc
7	3	c	cc

<colgroup><col style="width:48pt" span="9" width="64"> </colgroup><tbody>
</tbody>

Here is the code.

Sub myMacro()
    Rows("1:1").Insert
    Range("D1").Value = Range("A2").Value
    Range("E1").Value = Range("A2").Value

    firstRow = 2
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    firstColumn = 4
    
    If Range("D1").Value <> "" Then
        i = firstRow
        Do Until i > lastRow
            cStart = firstColumn
                lastColumn = Range("D1").End(xlToRight).Column
            output = True
            Do Until cStart > lastColumn Or output = False
                If Cells(1, cStart) = Range("A" & i).Value Then
                    output = False
                End If
                cStart = cStart + 1
            Loop
            If output = True Then
                Cells(1, cStart) = Range("A" & i).Value
                Cells(1, cStart + 1) = Range("A" & i).Value
            End If
            i = i + 1
        Loop
    
        lastColumn = Range("D1").End(xlToRight).Column
        i = firstRow
        Do Until i > lastRow
            cStart = firstColumn
            output = False
            Do Until cStart > lastColumn Or output = True
                If Cells(1, cStart) = Range("A" & i).Value Then
                    output = True
                    cStart = cStart - 1
                End If
                cStart = cStart + 1
            Loop
            lastRowOutput = Chr(cStart + 64)
            lastRowOutput = Range(lastRowOutput & Rows.Count).End(xlUp).Row + 1
            Cells(lastRowOutput, cStart) = Range("B" & i).Value
            Cells(lastRowOutput, cStart + 1) = Range("C" & i).Value
            i = i + 1
        Loop
    End If
    Rows("1:1").Delete
End Sub

 

[ztodd]

I see it a function and I guess I need to put it in some code calling it out right? So I don't know what to do with it without a code.

You can call it the same as calling a procedure. Use "Procedure" instead of "Function" if that makes you feel better.

It's a full solution- I got this output from it, which is how I interpreted what he wanted-

code.

	A	B	C	D	E	F	G	H	I
1	1	a	aa	a	aa
2	2	b	bb			b	bb
3	2	b	bb			b	bb
4	2	b	bb			b	bb
5	2	b	bb			b	bb
6	3	c	cc					c	cc
7	3	c	cc					c	cc

<tbody>
</tbody>

 

[WarPigl3t]

And now that I finished all that work, I figured out how to do it without headers. But I'm not doing it anymore. The solution was the value of the cell in the A column times 2 + 2. So for example cell A5 has 2 as the value. 2 X 2 + 2 = 6. So the data in B column would go in column 6 and then +1 to put the data from C in column 7. I wish I would have thought of that sooner so I didn't have to make that first loop to create headers. All the code could have gone in the bottom Loop.

 

[WarPigl3t]

I'm one of those kinds of people that can't stand broken things. I gave you code that worked before, but it was not perfect. Use this code. It's shorter, perfect, and does the exact same thing without creating headers.

Sub myMacro()
    firstRow = 1
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    firstColumn = 4
    lastColumn = Range("C1").End(xlToRight).Column
    If Range("D1").Value <> "" Then
        columnLetter = Chr(lastColumn + 64)
        Columns("D:" & columnLetter).ClearContents
    End If
    i = firstRow
    Do Until i > lastRow
        outputColumn = Range("A" & i).Value * 2 + 2
        lastRowOutput = Chr(outputColumn + 64)
        If Range(lastRowOutput & "1").Value <> "" Then
            lastRowOutput = Range(lastRowOutput & Rows.Count).End(xlUp).Row + 1
        Else
            lastRowOutput = 1
        End If
        Cells(lastRowOutput, outputColumn) = Range("B" & i).Value
        Cells(lastRowOutput, outputColumn + 1) = Range("C" & i).Value
        i = i + 1
    Loop
End Sub

 

[raulmadrid]

I'm one of those kinds of people that can't stand broken things. I gave you code that worked before, but it was not perfect. Use this code. It's shorter, perfect, and does the exact same thing without creating headers.

Sub myMacro()
    firstRow = 1
    lastRow = Range("A" & Rows.Count).End(xlUp).Row
    firstColumn = 4
    lastColumn = Range("C1").End(xlToRight).Column
    If Range("D1").Value <> "" Then
        columnLetter = Chr(lastColumn + 64)
        Columns("D:" & columnLetter).ClearContents
    End If
    i = firstRow
    Do Until i > lastRow
        outputColumn = Range("A" & i).Value * 2 + 2
        lastRowOutput = Chr(outputColumn + 64)
        If Range(lastRowOutput & "1").Value <> "" Then
            lastRowOutput = Range(lastRowOutput & Rows.Count).End(xlUp).Row + 1
        Else
            lastRowOutput = 1
        End If
        Cells(lastRowOutput, outputColumn) = Range("B" & i).Value
        Cells(lastRowOutput, outputColumn + 1) = Range("C" & i).Value
        i = i + 1
    Loop
End Sub

Thanks both as your both solutions are great. However, I somehow prefer WarPiglet code as it is more aligned with my real need.

Sorry to sound a bit demanding and absolutely amateur, but may I ask for your time to look into my attached spreadsheet to see if you can solve my real problem?

http://1drv.ms/1uM4I1V

The task is as follows:
1. Look through column B to choose unique value (sorted ascending) assigning to a specific staff, copy heading and that staff records to Outlook mail
2. For each staff, lookup Staff Full Name in Column E then copy into Outlook "To:" to send mail to that staff

In the attached file, I have used Ron De Bruin's code and able to copy every line to Outlook mail, but not the whole records of unique staff (for example, for staff number 2 with 4 records, current code copies 4 lines into 4 separate emails, while I need to copy 4 lines related to that staff to 1 email only.)

Sub Mail_Selection_Range_Outlook_Body()

'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim StartLine As Integer
    Dim EndLine As Integer
    Dim OutApp As Object
    Dim OutMail As Object
    Dim StrBody As String
    
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    
    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    'Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    
    StartLine = 6
    EndLine = Sheets("Pivot").Range("B2").Value
    
Do While StartLine < EndLine
      
    
    Set rng = Union(Sheets("Pivot").Range("F5:P5"), Sheets("Pivot").Range("F" & StartLine & ":P" & StartLine))
            

    On Error GoTo 0
    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    StrBody = "Hi " & Sheets("Pivot").Range("H6").Value & ",

As per current ATO requirements, we require a travel diary for trips over 6 days [B]including self-funded and externally-funded trips. [/B]

According to our database your travel diary for the trip(s) below is/are outstanding. 

"
                
    On Error Resume Next
    With OutMail
        .to = "Raul Huynh"
        .CC = ""
        .BCC = ""
        .Subject = "First Reminder: Outstanding Travel Diary"
        .HTMLBody = StrBody & RangetoHTML(rng) & "

Thank you for your cooperation.

" & "[B]Taxation"
        .Display   'or use .Send
    End With
    On Error GoTo 0
StartLine = StartLine + 1
    
Loop
    
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
    
End Sub

Function RangetoHTML(rng As Range)
' Working in Office 2000-2013
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Copy the range and create a new workbook to paste the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
    'Close TempWB
    TempWB.Close savechanges:=False
    'Delete the htm file we used in this function
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

This is where I get stuck. I tried to apply WarPiglet's code but unsuccessful. I don't know how to put WarPiglet code into a loop to copy a unique staff records to email, copy that staff name to Outlook receipient, send mail, then continue for the next staff.

This is way over my head...[/B]