PDA

View Full Version : [SOLVED] Assistance for code pasting data into few columns and leaving few columns blank



Silver
06-26-2016, 01:50 AM
Hello,

I have a code that looks for certain keywords and copies data from specific cells in col c on sheet1 and paste them into specific cols in sheet2.

Below is an example of how the request looks from which the data is pasted

16475

Below is an example of how the data gets pasted once the macro is run

16477

Another example of the data, but last 3 data is for more than 1 staff

16476

Below is an example of how the data gets pasted once the macro is run

16479

As you can see, last 3 data are pasted correctly (3 times) in their respective columns. But remaining datas are pasted once.

Below is the code that I'm using


Sub blah()

Set DestnSheet = Sheets("Sheet2") 'just so that this line is the only line to change if you want to change the destination sheet.


With DestnSheet


DestnRow = .Cells(.Rows.Count, "J").End(xlUp).Row + 1 'uses column J on destination sheet to determin which is the next clear row to put data into.


End With


FirstNameRow = 15 'most keywords' first names start in row 8.


With Sheets("Sheet1") 'ActiveSheet ''Activesheet, specific sheet, whichever.


Select Case .Range("C8") 'the keyword.


Case "ABC"


ToColms = Array("D", "N", "O", "G", "I", "E") 'these are destination columns


FromRows = Array(2, 5, 8, 11, 12, 15)


Case "def", "ghi", "zzz" 'this includes any other keywords that share the same destination column pattern.


ToColms = Array("C", "L", "J") 'these are destination columns


FromRows = Array(3, 5, 6)


Case "XYZ"


ToColms = Array("D", "N", "O", "G", "I", "Q", "R") 'these are destination columns


FromRows = Array(2, 5, 8, 11, 12, 13, 14)


FirstNameRow = 18


'Case Else


'ToColms = Array("P", "Q", "R", "S", "T") 'default destination columns for any other keyword not in above Cases.


'FromRows = Array(99, 98, 97, 96, 95)


End Select


i = LBound(ToColms) 'the rows on sheet1 (column C) where data is always pasted.


For Each rw In FromRows


DestnSheet.Cells(DestnRow, ToColms(i)).Value = .Cells(rw, "C").Value


i = i + 1


Next rw


Set Sce = .Cells(FirstNameRow, "C") 'first name location


If Sce.Value <> "" Then


Do


DestnSheet.Cells(DestnRow, "E").Value = Sce.Value


DestnSheet.Cells(DestnRow, "J").Value = Sce.Offset(1).Value 'cell below the name
DestnSheet.Cells(DestnRow, "X").Value = Sce.Offset(2).Value 'cell below the name

Set Sce = Sce.Offset(4) 'next additional name is 3 cells down


DestnRow = DestnRow + 1 'next ow down on destination sheet (sheet2)


Loop Until Sce.Value = ""


End If


End With


End Sub




Addition Required -

The code should paste data in their respective columns depending on last 3 data :

Example :

a) If last 3 data is for 1 staff, macro should paste data once in the respective columns
b) If last 3 data is for 2 staff, macro should paste data twice in the respective columns... so on

Any assistance will be highly appreciated.

Have attached sample sheet.

mdmackillop
06-26-2016, 01:09 PM
This could be a lot neater but I've just adjusted your code

Sub blah()
Dim arr, c As Range, r As Range, FA As String
Set DestnSheet = Sheets("Sheet2") 'just so that this line is the only line to change if you want to change the destination sheet.
FirstNameRow = 15 'most keywords' first names start in row 8.


'Find Ticket numbers
With Sheets("Sheet1").Columns("B")
Set c = .Find("Ticket number", after:=Cells(1, 2))
Set r = c
FA = c.Address
Do
Set c = .FindNext(c)
Set r = Union(r, c)
Loop Until c.Address = FA
End With


For Each cel In r
With Sheets("Sheet1") 'ActiveSheet ''Activesheet, specific sheet, whichever.
Select Case .Range("C8") 'the keyword.
Case "ABC"
ToColms = Array("D", "N", "O", "G", "I", "E") 'these are destination columns
FromRows = Array(2, 5, 8, 11, 12, 15)
Case "def", "ghi", "zzz" 'this includes any other keywords that share the same destination column pattern.
ToColms = Array("C", "L", "J") 'these are destination columns
FromRows = Array(3, 5, 6)
Case "XYZ"
ToColms = Array("D", "N", "O", "G", "I", "Q", "R") 'these are destination columns
FromRows = Array(2, 5, 8, 11, 12, 13, 14)
FirstNameRow = 18
'Case Else
'ToColms = Array("P", "Q", "R", "S", "T") 'default destination columns for any other keyword not in above Cases.
'FromRows = Array(99, 98, 97, 96, 95)
End Select
i = LBound(ToColms) 'the rows on sheet1 (column C) where data is always pasted.
With DestnSheet
DestnRow = .Range("D:X").Find("*", .Range("D1"), , , xlByRows, xlPrevious).Row + 1
End With
For Each rw In FromRows
DestnSheet.Cells(DestnRow, ToColms(i)).Value = .Cells(rw, "C").Value
i = i + 1
Next rw
DestnSheet.Cells(DestnRow, "E").Value = cel.Offset(, 1).Value
DestnSheet.Cells(DestnRow, "J").Value = cel.Offset(1, 1).Value 'cell below the name
DestnSheet.Cells(DestnRow, "X").Value = cel.Offset(2, 1).Value 'cell below the name
End With
Next cel
End Sub

Silver
06-26-2016, 07:52 PM
mdmackillop... PERFECT.

One more question

What part of the code should be changed if the data should get pasted from row 12.

mdmackillop
06-27-2016, 12:27 AM
What part of the code should be changed if the data should get pasted from row 12.
Not clear what you mean by that. If you mean FirstNameRow the can you search Column B for a term and set the row accordingly? This is not used in the code, the only reference being to "C8"

Silver
06-27-2016, 04:04 AM
The code currently copies data from sheet1 and pastes them from row 2 on sheet2.

What part of the code should be changed so the data is pasted from row 12 on sheet2

mdmackillop
06-27-2016, 05:22 AM
With DestnSheet
DestnRow = .Range("D:X").Find("*", .Range("D1"), , , xlByRows, xlPrevious).Row + 1
if DestnRow<12 then DestnRow=12
End With

Silver
06-27-2016, 11:12 AM
I was testing your code and everything seems to be working properly.

Except for one thing, if the last 3 data is for more than 1 staff, then macro is pasting the last 3 data in a mixed order.

Below is an example data -

16483

Below is how the code provided by you is pasting the data

16484

As you can see it's not in proper order.

Below is how the data should be pasted (proper order)

16485

mdmackillop
06-27-2016, 12:12 PM
What have you tried to fix the problem? We are here to assist, not to provide free solutions.
By the way, your sample only contained one ticket number repeated. If you provide sloppy samples, how can you expect a proper answer.

Silver
06-27-2016, 01:00 PM
Me and my colleague worked on the original code that I posted.

We were finding it difficult to achieve the last part wherein the remaining columns does not get updated with data. We are not experts, so, thought to approach professionals for assistance.

In the example provided, data in column B is the template that will be used throughout and the data in column C is what needs to be pasted in specific columns on sheet2. Data in column C will change on daily basis.

I humbly request to help me out here.

mdmackillop
06-27-2016, 01:04 PM
The issue lies in these 4 lines. Give it some thought. BTW, Professionals get paid.

Do
Set c = .FindNext(c)
Set r = Union(r, c)
Loop Until c.Address = FA

Silver
06-29-2016, 11:40 PM
I have been pondering for the past few days, searching the net for answers... I was not getting anywhere.

I was about to approach you for assistance. But did something in an unorthodox way and was able to achieve what I'm looking for.

Below is what I came up with


'Find Ticket numbers With Sheets("Sheet1").Columns("B")
Set c = .Find("Ticket number", after:=Cells(1, 2))
Set r = c
FA = c.Address
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
Set c = .FindNext(c)
Set r = Union(r, c)
End With

The code pastes the last 3 data in the correct order if it's for more than 1 staff... and so on.

Will be helpful if the above code can be shortened (or cleaned up)

mdmackillop
06-30-2016, 12:16 AM
Do
Set c = .FindNext(c)
If c.address = FA then exit do
Set r = Union(r, c)
Loop

Silver
07-02-2016, 03:48 AM
Many thanks for your assistance...:friends: