Finding Unique ID Number & Fill the Cells

[sooty8]

Hi All

I have attached a very basic example workbook -- normally there would be about 20 sheets all formated exactly the same but considerably more rows would be used. The "Input Text" sheet is what I use after receiving Emails in CSV an example on this sheet - click - Text To Columns - I then copy and paste the info into the correct row that matches the ID number and the column which holds the Code Number is it feasible to automate this proceedure with a Macro? an example on "Pack FC" sheet under the two header rows shows exactly what is required. Perhaps somebody could help or guide me in the right direction as I have no idea how to do this. Sometimes the Unique ID number is duplicated on other sheets in the workbook and on finding the number it would also fill the columns on this sheet with the same info.

Many Thanks

Sooty8

[Bob Phillips]

I can see where part of the data comes from, but where does the rest come from, like the names the BLA, CHE, FOR?

[sooty8]

Hi xld

thanks for a quick reply the data you refer to BLA, CHE, FOR is basically for me when reading the sheet they are abbrevations of place names so at a glance I know at the moment everything I paste is in the correct column.

Regards

Sooty8.

[Bob Phillips]

Fine, but where do you get them from so as to populate those cells.

[Simon Lloyd]

They look like headings from the other sheets, although i'm not sure which sheet the Op is referring to or by which criteria he expects to get the data.

[Bob Phillips]

Here is the code that transforms the data that is there



Sub TransposeData()
Dim LastRow As Long
Dim LastCol As Long
Dim ColNum As Long
Dim i As Long, j As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

With ActiveSheet

.Columns("A:A").TextToColumns Destination:=.Range("D1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
.Columns("E:E").Cut .Columns("B:B")
.Columns("D:D").Cut Destination:=.Columns("C:C")
.Columns("D:E").Delete
.Columns("A").Delete
.Rows("1:2").Insert

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("D1").Value = "CODE NUMBERS >>>>>>>"
For i = 3 To LastRow

ColNum = 0
On Error Resume Next
ColNum = Application.Match(.Cells(i, "B").Value, .Rows(1), 0)
On Error GoTo 0

If ColNum = 0 Then

ColNum = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
If ColNum Mod 2 = 0 Then ColNum = ColNum + 1
.Cells(1, ColNum).Value = .Cells(i, "B").Value
.Cells(1, ColNum).Resize(, 2).Merge True
.Cells(1, ColNum).Resize(, 2).HorizontalAlignment = xlCenter
End If

.Cells(i, ColNum).Value = .Cells(i, "C").Value
.Cells(i, ColNum + 1).Value = .Cells(i, "D").Value
Next i

.Columns("A:D").ColumnWidth = Array(14, 30, 28, 8)
.Range("D1").HorizontalAlignment = xlRight
.Range("A2:D2").Value = Array("ID NUMBER", "NAME", "CLUB", "SE")
ColNum = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
.Range("A1:A2").Resize(, ColNum).Interior.ColorIndex = 40

LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = LastRow To 3 Step -1

If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then

For j = 5 To LastCol Step 2

If .Cells(i, j).Value <> "" Then

.Cells(i, j).Resize(, 2).Copy .Cells(i - 1, j)
End If
Next j
.Rows(i).Delete
End If
Next i

.Range("C2:D2").HorizontalAlignment = xlCenter
.Columns(5).Resize(, LastCol - 3).ColumnWidth = 4.67
.Range("B3").Resize(LastRow, 3).ClearContents
End With

With Application

.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

[Simon Lloyd]

Bob, just as a side to the question in your code if you omit:

FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1))
won't the text to columns automatically build the array for the dimensions needed?

[sooty8]

Hi xld & Simon

Delayed replying to your great input and help due to the fact that this morning I was expecting an Email with new data ( Attached) pasted into the workbook after removing Macro's 1 & 2 everything worked perfectly and placed all the data in the correct columns on the Input Text sheet - is it possible once this is done it could loop through all the sheets in the workbook and where ever it finds the ID Number in column "A" it would insert the data starting at column "E" for that Id Number. The ID Number, Name, Club & SE are all entered permanently within the relevant sheets.

Once again thanks for your help

Regards

Sooty8.

[Bob Phillips]

No attachment.

I didn't understand your question.

[Bob Phillips]

Bob, just as a side to the question in your code if you omit:

FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1))
won't the text to columns automatically build the array for the dimensions needed?

Yes it will, I just cribbed that from the OPs original code.

[sooty8]

Hi xld

File attached I hope this time, In the original workbook there were sheets for Pack FC & Poyn RBLFC with the ID Numbers in Column "A" when the Input Sheet is completed is it possible to use the ID Number and the data generated to be inserted in the Workbook Sheets where ever the ID Number is found -- The ID Number is already in place on every sheet that it is required.

Have I explained it better? or should I also send the new Workbook?

Regards

Sooty8.

[sooty8]

Hi xld

Have attached new test workbook

Regards

Sooty8.

[Bob Phillips]

So you mean that the code should go through all of the sheets looking for the Id and pick up the match details, after the sheet has been formatted?

[sooty8]

Hi Xld

Thanks for all your help and in answer to your question -- yes if its possible it would save me hours of cutting & pasting

Regards

Sooty8.

[Bob Phillips]

Option Explicit

Sub TransposeData()
Dim sh As Worksheet
Dim LastRow As Long
Dim LastCol As Long
Dim ColNum As Long
Dim Pos As Long
Dim i As Long, j As Long

With Application

.ScreenUpdating = False
.Calculation = xlCalculationManual
.EnableEvents = False
End With

With ActiveSheet

.Columns("A:A").TextToColumns Destination:=.Range("D1"), _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, _
Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), _
Array(3, 1), Array(4, 1)), _
TrailingMinusNumbers:=True
.Columns("E:E").Cut .Columns("B:B")
.Columns("D:D").Cut Destination:=.Columns("C:C")
.Columns("D:E").Delete
.Columns("A").Delete
.Rows("1:2").Insert

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
.Range("D1").Value = "CODE NUMBERS >>>>>>>"
For i = 3 To LastRow

ColNum = 0
On Error Resume Next
ColNum = Application.Match(.Cells(i, "B").Value, .Rows(1), 0)
On Error GoTo 0

If ColNum = 0 Then

ColNum = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
If ColNum Mod 2 = 0 Then ColNum = ColNum + 1
.Cells(1, ColNum).Value = .Cells(i, "B").Value
.Cells(1, ColNum).Resize(, 2).Merge True
.Cells(1, ColNum).Resize(, 2).HorizontalAlignment = xlCenter
End If

.Cells(i, ColNum).Value = .Cells(i, "C").Value
.Cells(i, ColNum + 1).Value = .Cells(i, "D").Value
Next i

.Columns("A:D").ColumnWidth = Array(14, 30, 28, 8)
.Range("D1").HorizontalAlignment = xlRight
.Range("A2:D2").Value = Array("ID NUMBER", "NAME", "CLUB", "SE")
ColNum = .Cells(1, .Columns.Count).End(xlToLeft).Column + 1
.Range("A1:A2").Resize(, ColNum).Interior.ColorIndex = 40

LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = LastRow To 3 Step -1

If .Cells(i, "A").Value = .Cells(i - 1, "A").Value Then

For j = 5 To LastCol Step 2

If .Cells(i, j).Value <> "" Then

.Cells(i, j).Resize(, 2).Copy .Cells(i - 1, j)
End If
Next j
.Rows(i).Delete
End If
Next i

.Range("B3").Resize(LastRow, 3).ClearContents
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
For i = 3 To LastRow

For Each sh In Worksheets

If sh.Name <> .Name Then

Pos = 0
On Error Resume Next
Pos = Application.Match(Trim(.Cells(i, "A").Value), sh.Columns(1), 0)
On Error GoTo 0
If Pos > 0 Then

.Cells(i, "B").Value = sh.Cells(Pos, "B").Value
.Cells(i, "C").Value = sh.Cells(Pos, "C").Value
.Cells(i, "D").Value = sh.Cells(Pos, "D").Value
Exit For
End If
End If
Next sh
Next i

.Range("C2:D2").HorizontalAlignment = xlCenter
.Columns(5).Resize(, LastCol - 3).ColumnWidth = 4.67
End With

With Application

.EnableEvents = True
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With

End Sub

[sooty8]

Hi Xld

I apologise for troubling you again -- however have cut and pasted the new code and nothing has changed if I read the code correctly


If sh.Name <> .Name Then

Pos = 0
On Error Resume Next
Pos = Application.Match(Trim(.Cells(i, "A").Value), sh.Columns(1), 0)
On Error Goto 0
If Pos > 0 Then

.Cells(i, "B").Value = sh.Cells(Pos, "B").Value
.Cells(i, "C").Value = sh.Cells(Pos, "C").Value
.Cells(i, "D").Value = sh.Cells(Pos, "D").Value
Exit For
End If
End If
Next sh
Next i
it should put the name, club,se on the Input Text sheet however it doesn't happen and what I really need is the last 2 parts of the array eg: 147,1331 to go on the sheet where it finds the ID Number and in columns "E" & "F" and so on.

I have to sign off now for a few hours hospital visit this afternoon

Regards

Sooty8.

[Bob Phillips]

It di, at least for me. Are you also saying it doesn't add the 147,1331 now either?

[sooty8]

Hi Xld

That is correct the last two parts of the array do not go on to any of the sheets Pack FC or Poyn RBLFC - it works superbly on the Input Text -- however does not enter any other of the sheets.

Must go now the my transport has arrived and the Docs will be waiting for me.

Regards

Sooty8.

[Bob Phillips]

So is the input sheet just a temporary scratch pad, do we not need to reformat that sheet as I did?

[sooty8]

Hi Xld

Long delay -- dialysis is not easy to take on some days - On reading everything above it appears to me that you may have an easier solution from what I started with - I just want to get the final two parts of the Array 149,884 on the correct row when finding the ID No. and in the correct Columns using the Code No. - In what ever sheet in the workbook that has the ID No. In column "A" -- the "Input Text" Sheet I just copy from the Email in column "A" that is why I started with Text to Columns and I was hoping somehow with help to get the info into the different sheets -- it seems as though I have dropped a few clangers along the way. That's the way of a novice trying to learn from experts.

Regards

Sooy8.