PDA

View Full Version : [SOLVED] Loop to copy and paste first cell of repeated values



Dave T
01-29-2018, 06:42 AM
Hello All,

I have a series of photos taken at a variety of bridges.

Column A has the Plan Number of the bridge
Column B has the sorting order for the photos for each individual bridge
Column C has a description of each photo
Column D has the number of each photo as created by the camera

The data has been supplied to me in one contiguous block i.e. all photos for each individual structure are all grouped together (refer to Sheet2 for an example).
I have found quite a few macro examples that will insert blank rows between repeated values that are in column A (two examples are within the attached workbook).

What I am after is a macro that will loop down column A and only copy the first of each Plan Number up one row and two cells to the right (refer to Sheet1 for an example).
I am happy to keep them as two separate macros i.e. one to insert the blank rows and the other to copy the first value with a PN prefix.

At some stage later column A will be deleted so the the Plan Number with the PN prefix above the photos description column then becomes the heading for that group of photos.

Regards,
Dave T

georgiboy
01-29-2018, 07:36 AM
Could try:


Option Explicit

Sub M01_InsertRows()


Dim LastRow As Long
Dim rowPtr As Long, x As Long

Application.ScreenUpdating = False

LastRow = Range("A" & Rows.Count).End(xlUp).Row
For rowPtr = LastRow To 2 Step -1
If Not IsEmpty(Range("A" & rowPtr)) Then
If Range("A" & rowPtr) <> Range("A" & rowPtr - 1) Then
For x = 1 To 2
Range("A" & rowPtr).EntireRow.Insert
Next x
Range("C" & rowPtr + 1).Value = "PN" & Range("A" & rowPtr + 2).Value
Range("C" & rowPtr + 1).Font.Bold = True
End If
End If
Next

Application.ScreenUpdating = True

End Sub

Hope this helps

paulked
01-29-2018, 08:18 AM
Sub CreateList()
Dim rw1 As Long, lr As Long, cPlN As Long, x As Long, cl As Long
rw1 = 2
lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With Sheet1.Range("A2:D" & lr)
.ClearContents
.ClearFormats
End With
lr = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
With Sheet2
cPlN = .Cells(2, 1).Text
With Sheet1.Cells(rw1, 3)
.Value = "PN" & CStr(cPlN)
.Font.Bold = True
End With
rw1 = rw1 + 1
For x = 2 To lr
If .Cells(x, 1) = cPlN Then
For cl = 1 To 4
Sheet1.Cells(rw1, cl) = .Cells(x, cl)
Next
rw1 = rw1 + 1
Else
cPlN = .Cells(x, 1).Text
rw1 = rw1 + 1
With Sheet1.Cells(rw1, 3)
.Value = "PN" & CStr(cPlN)
.Font.Bold = True
End With
rw1 = rw1 + 1
For cl = 1 To 4
Sheet1.Cells(rw1, cl) = .Cells(x, cl)
Next
rw1 = rw1 + 1
End If
Next
End With
End Sub

paulked
01-29-2018, 08:30 AM
Hey Georgiboy, you got there fast! Slick too :clap:

georgiboy
01-29-2018, 10:43 AM
Thanks Paul

cant take any credit for this though as I did only modify the code provided in the sample file.

was going to look at an array version but I haven’t the time plus might only be worth it if we are talking 100000 rows of data.

Dave T
01-29-2018, 04:41 PM
Wow...

Thank you very much georgiboy and paulked,

Your replies are much more than I had hoped for.

georgiboy's reply is probably the best as I do not have a Sheet2 with the values to copy from, but paulked reply is a very interesting example that might help me in future projects.
When I was testing the various macros I found online, I was using a macro to delete the data on Sheet1 in columns A to D and using Sheet2 'reset' the data on Sheet1 for the next test macro.
I have still yet to find a good macro to clear and reset a worksheet so I can work through other test macros.

After I had posted my question I thought that offset might be a better search term and then I found another macro (with comments), I have modified, that works quite well:


Sub Order_By_Column_A()
'https://www.mrexcel.com/forum/excel-questions/487280-macro-sort-then-insert-row-above-each-unique-value.html

Dim Rng As Range
Dim Dn As Range
Dim Rw As Long

Application.ScreenUpdating = False

'Sets "Rng" for all data in column "A", row 2 on
Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))

'Resizes the Rng for 4 columns and sorts
'Rng.Resize(, 4).Sort Key1:=Range("A2"), Order1:=xlAscending 'uncomment if you want to sort range

'Loops through range from bottom to top
'NB:- If you loop from the top the row is inserted in front
'of the loop, which does not work.
'
'When adding or deleting rows always start from the Bottom
For Rw = Rng.Count To 2 Step -1 'loop backward

With Range("A" & Rw)
'The "." values below refer to the "With" Range above

If .Value <> .Offset(-1).Value Then
.EntireRow.Insert
.EntireRow.Insert

'This offset range is one cell above the "Rw" row value
.Offset(-1, 2) = "PN" & .Value
.Offset(-1, 2).Font.Bold = True


End If
End With
Next Rw

'Stops screen Flashing
Application.ScreenUpdating = True

End Sub

I really appreciate both of you taking the time to help me out.

Regards,
Dave T

paulked
01-29-2018, 06:34 PM
No worries Dave, but you did have a sheet 2 in the file you attached, it had the unsorted data on and sheet 1 had the sorted data.

In my code I cleared Sheet 1 rows 2 to lastrow (started at 2 to keep the headers in) with this code:



lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
With Sheet1.Range("A2:D" & lr)
.ClearContents
.ClearFormats
End With


Change the range to suit the area you want to clear.

Cheers

Dave T
01-30-2018, 02:21 AM
Hello paulked,

I had actually copied the data to Sheet2 for the purpose of posting it on this forum so that if anyone was testing their macro it would be easy to copy the original data back.
In hind site your solution is of great value to me as it means I do not have to mess with the original data supplied to me.
Your solution means I can copy the worksheet and run the macro on this worksheet without messing up the original data.

Having two replies that interpreted my question slightly differently yet both producing the same end result is very helpful.
Thanks again for your help.

Regards,
Dave T

paulked
01-30-2018, 03:30 AM
You're welcome.

p45cal
01-30-2018, 07:22 AM
Late in the day, but a quite different approach. Button on Sheet2 of the attached runs this code:
Sub blah()
Set pvtSource = Sheets("Sheet2").Range("A1").CurrentRegion 'adjust to correct sheet name
Set NewSht = Sheets.Add(After:=Sheets(Sheets.Count)) 'add a new sheet
Set NewTableDestn = NewSht.Cells(1) 'adjust for where you want the new table to be
With ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=pvtSource).CreatePivotTable(TableDestination:=NewTableDestn)
.ShowDrillIndicators = False
.RowAxisLayout xlTabularRow
.ColumnGrand = False
.RowGrand = False
.PivotFields("Plan No.").Orientation = xlRowField
.PivotFields("Photo No.").Orientation = xlRowField
.PivotFields("Photo No.").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
.PivotFields("Description").Orientation = xlRowField
.PivotFields("Description").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
.PivotFields("Image No.").Orientation = xlRowField
.PivotFields("Image No.").Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
.PivotFields("Plan No.").Subtotals = Array(True, False, False, False, False, False, False, False, False, False, False, False)
.PivotFields("Plan No.").LayoutForm = xlOutline
.PivotFields("Plan No.").LayoutBlankLine = True
.TableStyle2 = ""
Set ptRng = .TableRange2
End With
'convert pivot to plain range:
x = ptRng
ptRng.ClearContents
ptRng.Value = x
'move and adjust Plan No. headers:
Set pns = ptRng.Columns(1)
For Each pn In pns.SpecialCells(xlCellTypeConstants, 1).Cells
With pn.Offset(, 2)
.Value = "PN" & pn.Value
.Font.Bold = True
End With
Next pn
pns.EntireColumn.Delete 'remove first column
ptRng.EntireColumn.AutoFit
End Sub
There is no need to sort the data on Sheet2 first.
See comments in the code for adjustments.
Results in this sort of thing on a new sheet:
21481

ps. A couple more tweaks to get the result exactly as columns B:D of Sheet1:
Change:
ptRng.ClearContents
to:
ptRng.Clear

and add the line:
ptRng.Rows(1).Font.Bold = True
directly before the line:
ptRng.EntireColumn.AutoFit

paulked
01-30-2018, 08:54 AM
That's tidy!

Dave T
02-05-2018, 12:47 AM
Hello p45cal,

Just out of curiosity I have been try to declare the variables in your amazing solution.

Can you please provide these for my information.

Regards,
Dave T

p45cal
02-05-2018, 04:46 AM
Either:
Dim pvtSource As Range, NewSht As Worksheet, NewTableDestn As Range, ptRng As Range, x, pns As Range, pn As Range
or:
Dim pvtSource, NewSht, NewTableDestn, ptRng, x, pns, pn

Dave T
02-05-2018, 03:19 PM
Thanks p45cal,

After your very different approach I had looked around for other online examples using key words from your solution.
Looking back at what I had tried from what I had seen, I had worked out all of the variables in your first line except for x.

If the other variables refer to Range, Worksheet... does the x need to refer to anything or if it is left blank does it have a default variable ??

Thanks for all your help p45cal,

Regards,
Dave T

p45cal
02-06-2018, 08:17 AM
…except for x.
If the other variables refer to Range, Worksheet... does the x need to refer to anything or if it is left blank does it have a default variable ??
x is a Variant type variable, the default if it's not specified. It needs to be because it's likely to hold a variety of data types; some text, some numbers. x is a temporary hold (an array of values) of the entire pivot table's values (x = ptRng, for which read the implicit x = ptRng.value), where beforehand ptRng had been set to the entire pivot table range (.tableRange2), while the pivot is deleted. x is then used to repopulate the deleted range, now a plain range.