Hi All,
I'm relatively new to creating macros but have been working on the attached code for some time, unfortunately it ends with an error which i haven't been able to eliminate. The problem line is highlighted in red text. Any help on the associated error would be much appreciated.
Thanks in advance.
brentsimp
I'm relatively new to creating macros but have been working on the attached code for some time, unfortunately it ends with an error which i haven't been able to eliminate. The problem line is highlighted in red text. Any help on the associated error would be much appreciated.
Thanks in advance.
brentsimp
Code:
Sub Intertek_Assays()
Dim lCount As Long
Dim rFoundCell As Range
Dim CurrentSearch As String
Dim SearchResult As String
Dim inColumnsMax As Long
Dim outColumnsMax As Long
Dim HeaderColumn As Long 'Column Reference for the LookupTable where the Headers are stored
Dim sheet_LookUP As String
Dim Concatenate As String
Dim HeaderCount As Long
Dim RawData As String
Dim OutPutData As String
Dim CurrentInput As Long
Dim UnMatchedColums As Long
Dim Niton_ReadingColumn As Integer
Dim PrefillColumn As Long
Dim rPrefillCell As Range
Dim inRowsMax As Long
Dim FinishedColumnOrder As Integer
Dim rCopy As Range
Dim rDestination As Range
Dim ThisBOOK As String
'Dim Sortorder As Address
'CurrentSearch = "Test"
'inColumnsMax = 100 'set to auto length later
'outColumnsMax = 100 'set to auto length later
HeaderColumn = 3
sheet_LookUP = "INTERTEK_LOOKUP"
'HeaderCount = 100 ' WorksheetFunction.Count(Columns(HeaderColum))
FinishedColumnOrder = 2
ActiveSheet.Name = "Raw_Data"
RawData = ActiveSheet.Name
Sheets.Add.Name = "Finished"
OutPutData = "Finished"
Worksheets(RawData).Activate
Columns("B:D").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Cells(1, 1).Select
Rows("8:8").Select 'Insert row and concatenate'
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A8").Select
Application.CutCopyMode = False
ActiveCell.FormulaR1C1 = "=CONCATENATE(R[-7]C,""_"",R[-6]C,""_"",R[-4]C)"
Range("A8").Select
Selection.AutoFill Destination:=Range("A8:AZ8"), Type:=xlFillDefault
Range("A8:AO8").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("B5").Select 'add job number and dates'
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-1],52)"
Range("B9").Select
ActiveCell.FormulaR1C1 = "=LEFT(R[-4]C,15)"
Range("D5").Select
ActiveCell.FormulaR1C1 = "=RIGHT(RC[-3],34)"
Range("D9").Select
ActiveCell.FormulaR1C1 = "=LEFT(R[-4]C,10)"
Columns("B:B").ColumnWidth = 18
Columns("C:C").ColumnWidth = 12.71
Columns("D:D").EntireColumn.AutoFit
Range("B9:D9").Select 'fill down job number and dates'
Application.CutCopyMode = False
Selection.Copy
Range("B9:D500").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A8").Select 'add text'
ActiveCell = "Sample_Number"
Range("B8").Select
ActiveCell.FormulaR1C1 = "job_no"
Range("C8").Select
ActiveCell.FormulaR1C1 = "date_received"
Range("D8").Select
ActiveCell.FormulaR1C1 = "date_reported"
Rows("1:7").Select 'delete header rows'
Selection.Delete Shift:=xlUp
Workbooks("SIMP_ASSAY_MACRO.XLS").Worksheets(sheet_LookUP).Copy Before:=ActiveSheet
Worksheets(sheet_LookUP).Activate
Cells(1, HeaderColumn).Select
Selection.End(xlDown).Select
outColumnsMax = ActiveCell.Row - 1 'this finds how many total rows
For HeaderCount = 1 To outColumnsMax
Worksheets(OutPutData).Cells(1, HeaderCount).Value = Worksheets(sheet_LookUP).Cells(HeaderCount + 1, HeaderColumn).Value
'Cells(1, lCount).Value = .Cells(lCount + 1, HeaderColumn).Value
Next HeaderCount
Set rFoundCell = Worksheets(sheet_LookUP).Range("A1")
'rFoundCell.Activate
lCount = 1
Do Until lCount = inColumnsMax 'There should be only one match. 'WorksheetFunction.CountIf(Columns(1), "Cat")
CurrentSearch = Worksheets(RawData).Cells(1, lCount).Value
Set rFoundCell = Columns(1).find(What:=CurrentSearch, After:=Worksheets(sheet_LookUP).Range("A1"), _
LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If rFoundCell Is Nothing Then
Worksheets(RawData).Columns(lCount).Interior.ColorIndex = 6 'color yellow to indicate no tansfer
UnMatchedColums = UnMatchedColums + 1
Else:
'rFoundCell.Activate
Set rCopy = Worksheets(RawData).Columns(lCount)
rCopy.Copy
[COLOR=#ff0000] Set rDestination = Worksheets(OutPutData).Columns(rFoundCell.Offset(0, 1).Value)[/COLOR]
rDestination.PasteSpecial xlPasteValuesAndNumberFormats ' Operation:= _
' xlNone , SkipBlanks:=False, Transpose:=False
' Destination.:=Worksheets(OutPutData).Columns(rFoundCell.Offset(0, 1).Value) 'Copy and paste into appropriate column
'Worksheets(RawData).Columns(lCount).Copy _
' Destination:=Worksheets(OutPutData).Columns(rFoundCell.Offset(0, 1).Value) 'Copy and paste into appropriate column
Worksheets(OutPutData).Cells(1, (rFoundCell.Offset(0, 1).Value)).Value = rFoundCell.Offset(0, 2).Value 'rename column header
rCopy.Interior.ColorIndex = 4 ' Worksheets(RawData).Columns(lCount).Interior.ColorIndex = 4 'color green to indicate all good and transfered
' rCopy.Cells.Activate
End If
If inRowsMax = 0 Then
If rFoundCell.Offset(0, 2).Value Like "samp_id" Then
'determine the number or total readings
Worksheets(RawData).Activate
Cells(1, lCount).Select
Selection.End(xlDown).Select
inRowsMax = ActiveCell.Row 'this finds how many total rows
Worksheets(sheet_LookUP).Activate
End If
End If
lCount = lCount + 1
Loop
End Sub
Last edited by a moderator:
