Below is what I have so far. Can anybody help me to figure out how to get
this to work on a new spreadsheet? See below for code.
Sub GetRows()
Dim FirstCell As Range, LastCell As Range
On Error Resume Next
Dim Firstrow As Long, Lastrow As Long
Dim Wordstring As String
Dim filePath As String
Dim I As Integer
Dim FName As Variant
Dim Rangecount As Integer
Dim intresult As Long
Dim NVariable As String
Dim MVariable As String
Dim AVariable As String
Dim AVARSTRING As String
Dim FVariable As String
Dim FVARSTRING As String
Dim EVariable As String
Dim EVARSTRING As String
Dim NandMVariable As String
Dim NANDMVARSTRING As String
Call workbook_open
Kill (filePath = ActiveWorkbook.Path & "\Seqfile.rdf")
Worksheets.Select
Call FormatData
I = 0
Tried = False
Tried2 = False
Wordstring = "$RDFILE 1" & vbCrLf & _
"$DATM " & Date & " " & Time & vbCrLf & _
"$RIREG 1" & vbCrLf & _
"$DTYPE BATCH:CHEMIST" & vbCrLf & _
"$DATUM REIDHAAJ" & vbCrLf & _
"$DTYPE BATCH:STRUCT_CMNT" & vbCrLf & _
"$DATUM [NUCLEIC ACID]" & vbCrLf & _
"$DTYPE STRUCTURE" & vbCrLf & _
"$DATUM $MFMT"
filePath = ActiveWorkbook.Path & "\Seqfile.rdf"
Open filePath For Output As #1
Print #1, Wordstring
Do
GetCell:
On Error Resume Next
Set FirstCell = Application.InputBox("Enter top left data cell - ONE
cell only ", Type:=8)
On Error GoTo 0
If FirstCell Is Nothing Then
MsgBox "You pressed Cancel!" & IIf(Tried, "AGAIN! Good-bye!", "!")
If Tried Then Exit Sub
Tried = True
GoTo GetCell
Else
MsgBox FirstCell.Address
End If
Loop Until FirstCell.Count = 1
Firstrow = FirstCell.Row
Do
GetCell2:
On Error Resume Next
Set LastCell = Application.InputBox("Enter bottom right data cell - ONE
cellonly ", Type:=8)
On Error GoTo 0
If LastCell Is Nothing Then
MsgBox "You pressed Cancel!" & IIf(Tried, "AGAIN! Good-Bye!", "!")
If Tried2 Then Exit Sub
Tried2 = True
GoTo GetCell2
Else
MsgBox LastCell.Address
End If
Loop Until LastCell.Count = 1
Lastrow = LastCell.Row
Firstrow = Int(Firstrow)
Lastrow = Int(Lastrow)
MsgBox Firstrow & " - " & Lastrow
Rangecount = Lastrow - Firstrow
MsgBox Rangecount & " records exported"
Range(Firstrow & ":" & Lastrow).Select
For I = Firstrow To Lastrow
If IsEmpty(Cells(I, "C").Value) Then
Dim G As Variant
Dim H As Variant
'Select Case IsEmpty(Cells(I, "G").Value) Or IsNull(Cells(I,
"G").Value) 'Cells(I, "G").Value = " "
If IsEmpty(Cells(I, "N").Value) Or Cells(I, "N").Value = "" Then
NVariable = ""
Else: NVariable = Cells(I, "N").Value
End If
If IsEmpty(Cells(I, "M").Value) Or Cells(I, "M").Value = "" Then
MVariable = ""
Else: MVariable = ""
End If
NandMVariable = NVariable + MVariable
If IsEmpty(NandMVariable) Or NandMVariable = "" Then
NANDMVARSTRING = ""
ElseIf (IsEmpty(NVariable) And NVariable = "" And Not
IsEmpty(MVariable)) Then
NANDMVARSTRING = "$DATUM " & MVariable & vbCrLf
ElseIf (IsEmpty(MVariable) And MVariable = "" And Not
IsEmpty(NVariable)) Then
NANDMVARSTRING = "$DATUM " & NVariable & vbCrLf
ElseIf Not IsEmpty(NandMVariable) Then
NANDMVARSTRING = "$DATUM " & NVariable & "_" & MVariable &
vbCrLf
End If
If IsEmpty(Cells(I, "A").Value) Or Cells(I, "A").Value = "" Then
AVariable = ""
Else: AVariable = Cells(I, "A").Value
End If
If IsEmpty(AVariable) Or AVariable = "" Then
AVARSTRING = ""
Else
AVARSTRING = "$DATUM siRNA for Gene target: " & AVariable & vbCrLf
End If
If IsEmpty(Cells(I, "F").Value) Or Cells(I, "F").Value = "" Then
FVariable = ""
Else: FVariable = Cells(I, "F").Value
End If
If IsEmpty(FVariable) Or FVariable = "" Then
FVARSTRING = ""
Else
FVARSTRING = "GeneIndex Id: " & FVariable & vbCrLf
End If
If IsEmpty(Cells(I, "E").Value) Or Cells(I, "E").Value = "" Then
EVariable = ""
Else: EVariable = Cells(I, "E").Value
End If
If IsEmpty(EVariable) Or EVariable = "" Then
EVARSTRING = ""
Else: EVARSTRING = "Accession number: " & EVariable & vbCrLf
End If
Print #1, vbCrLf; " -ISIS- 10310514382D" & vbCrLf & vbCrLf _
; " 0 0 0 0 0 0 0 0 0 0999 v2000" & vbCrLf _
; "M END" & vbCrLf _
; "$DTYPE BATCH:LAB_JOURNAL" & vbCrLf _
; NANDMVARSTRING _
; "$DTYPE BATCH:LIN_STRUCT_CODE" & vbCrLf _
; "$DATUM N" & vbCrLf _
; "$DTYPE BATCH:LIN_STRUCT_DESC" & vbCrLf _
; "$DATUM Pool components: Pool1-1; Pool1-2; Pool1-3" &
vbCrLf _
; "$DTYPE BATCH:PRODUCER(1):PRODUCER" & vbCrLf _
; "$DATUM " & Cells(I, "R").Value & ";", vbCrLf _
; "$DTYPE BATCH:PREP_DESCR" & vbCrLf _
; AVARSTRING _
; FVARSTRING _
; EVARSTRING _
; "$DTYPE BATCH:GENERIC_NAME(1):GENERIC_NAME" & vbCrLf _
; "$DATUM " & Cells(I, "B").Value & vbCrLf _
; "$RIREG " & I - 2 & vbCrLf _
; "$DTYPE BATCH:CHEMIST" & vbCrLf _
; "$DATUM REIDHAAJ" & vbCrLf _
; "$DTYPE BATCH:STRUCT_CMNT" & vbCrLf _
; "$DATUM [NUCLEIC ACID]" & vbCrLf _
; "$DTYPE STRUCTURE" & vbCrLf _
; "$DATUM $MFMT"
Else
'Select Case IsEmpty(Cells(I, "H").Value) Or IsNull(Cells(I,
"H").Value) 'Cells(I, "H").Value = " "
If IsEmpty(Cells(I, "N").Value) Or Cells(I, "N") = "" Then
NVariable = ""
Else: NVariable = Cells(I, "N").Value
End If
If IsEmpty(Cells(I, "M").Value) Or Cells(I, "N") = "" Then
MVariable = ""
Else: MVariable = Cells(I, "M").Value
End If
NandMVariable = NVariable + MVariable
If IsEmpty(NandMVariable) Or NandMVariable = "" Then
NANDMVARSTRING = ""
ElseIf (IsEmpty(NVariable) And NVariable = "" And Not
IsEmpty(MVariable)) Then
NANDMVARSTRING = "$DATUM " & MVariable & vbCrLf
ElseIf (IsEmpty(MVariable) And MVariable = "" And Not
IsEmpty(NVariable)) Then
NANDMVARSTRING = "$DATUM " & NVariable & vbCrLf
ElseIf Not IsEmpty(NandMVariable) Then
NANDMVARSTRING = "$DATUM " & NVariable & "_" & MVariable &
vbCrLf
End If
If IsEmpty(Cells(I, "A").Value) Or Cells(I, "A").Value = ""
Then
AVariable = ""
Else: AVariable = Cells(I, "A").Value
End If
If IsEmpty(AVariable) Then
Else
AVARSTRING = "$DATUM siRNA for Gene target: " & AVariable & vbCrLf
End If
If IsEmpty(Cells(I, "F").Value) Or Cells(I, "F").Value = "" Then
FVariable = ""
Else: FVariable = Cells(I, "F").Value
End If
If IsEmpty(FVariable) Or FVariable = "" Then
FVARSTRING = ""
Else
FVARSTRING = "GeneIndex Id: " & FVariable & vbCrLf
End If
If IsEmpty(Cells(I, "E").Value) Or Cells(I, "E").Value = "" Then
EVariable = ""
Else: EVariable = Cells(I, "E").Value
End If
If IsEmpty(EVariable) Or EVariable = "" Then
EVARSTRING = ""
Else: EVARSTRING = "Accession number: " & EVariable & vbCrLf
End If
Print #1, vbCrLf; " -ISIS- 10310514382D" & vbCrLf & vbCrLf _
; " 0 0 0 0 0 0 0 0 0 0999 v2000" & vbCrLf _
; "M END" & vbCrLf _
; "$DTYPE BATCH:LAB_JOURNAL" & vbCrLf _
; NANDMVARSTRING _
; "$DTYPE BATCH:LIN_STRUCT_CODE" & vbCrLf _
; "$DATUM N" & vbCrLf _
; "$DTYPE BATCH:LIN_STRUCT_DESC" & vbCrLf _
; "$DATUM Sense Strand: " & Cells(I, "C").Value; ";" & "
Antisense Strand:" & vbCrLf _
; Cells(I, "D").Value & vbCrLf _
; "$DTYPE BATCH:PRODUCER(1):PRODUCER" & vbCrLf _
; "$DATUM " & Cells(I, "R").Value & vbCrLf _
; "$DTYPE BATCH:PREP_DESCR" & vbCrLf _
; AVARSTRING _
; FVARSTRING _
; EVARSTRING _
; "$DTYPE BATCH:GENERIC_NAME(1):GENERIC_NAME" & vbCrLf _
; "$DATUM " & Cells(I, "B").Value & vbCrLf _
; "$RIREG " & I - 2 & vbCrLf _
; "$DTYPE BATCH:CHEMIST" & vbCrLf _
; "$DATUM REIDHAAJ" & vbCrLf _
; "$DTYPE BATCH:STRUCT_CMNT" & vbCrLf _
; "$DATUM [NUCLEIC ACID]" & vbCrLf _
; "$DTYPE STRUCTURE" & vbCrLf _
; "$DATUM $MFMT"
End If
Next I
Close #1
End Sub
Sub FormatData()
Dim wksCurrent As Worksheet
Dim wksNew As Worksheet
Dim rngHeadings As Range
Dim rngCurrent As Range
Set wksCurrent = ActiveSheet 'Could be any sheet you want
Set wksNew = Worksheets.Add
With wksCurrent 'Assume headings are in row 1
Set rngHeadings = .Range(.Range("A1"), .Cells(1,
Columns.Count).End(xlToLeft))
End With
For Each rngCurrent In rngHeadings
Select Case rngCurrent.Value
Case "Gene target" 'Heading This Goes to A
rngCurrent.EntireColumn.Copy wksNew.Columns("A")
Case "siRNA name" 'Heading That Goes to B
rngCurrent.EntireColumn.Copy wksNew.Columns("B")
Case "Sense strand (5' -> 3')" 'Heading The Other Goes to C
rngCurrent.EntireColumn.Copy wksNew.Columns("C")
Case "Antisense strand (5' -> 3')" 'Heading that goes to column D
rngCurrent.EntireColumn.Copy wksNew.Columns("D")
Case "Accession number" 'Heading that goes to column E
rngCurrent.EntireColumn.Copy wksNew.Columns("E")
Case "GeneIndex ID" 'Heading that goes to column F
rngCurrent.EntireColumn.Copy wksNew.Columns("F")
Case "Position in sequence" 'Heading that goes to column G
rngCurrent.EntireColumn.Copy wksNew.Columns("G")
Case "CDS" 'Heading that goes to column H
rngCurrent.EntireColumn.Copy wksNew.Columns("H")
Case "Distance relative to AUG" 'Heading that goes to column I
rngCurrent.EntireColumn.Copy wksNew.Columns("I")
Case "Number of G/C in duplex region" 'Heading that goes to
column J
rngCurrent.EntireColumn.Copy wksNew.Columns("J")
Case "Modification" 'Heading that goes to column K
rngCurrent.EntireColumn.Copy wksNew.Columns("K")
Case "Order designation" 'Heading that goes to column L
rngCurrent.EntireColumn.Copy wksNew.Columns("L")
Case "Date ordered" 'Heading that goes to column M
rngCurrent.EntireColumn.Copy wksNew.Columns("M")
Case "Synthesis designation" 'Heading that goes to column N
rngCurrent.EntireColumn.Copy wksNew.Columns("N")
Case "Separate strands or duplex" 'Heading that goes to column O
rngCurrent.EntireColumn.Copy wksNew.Columns("O")
Case "Bottom strand overhang matches sense strand sequence"
'Heading that goes to column P
rngCurrent.EntireColumn.Copy wksNew.Columns("P")
Case "Top strand overhang matches antisense strand sequence" '
Heading that goes to column Q
rngCurrent.EntireColumn.Copy wksNew.Columns("Q")
Case "Synthesized by" 'Heading that goes to column R
rngCurrent.EntireColumn.Copy wksNew.Columns("R")
Case "Pool components" 'Heading that goes to column S
rngCurrent.EntireColumn.Copy wksNew.Columns("S")
Case "Freezer box" 'Heading that goes to column T
rngCurrent.EntireColumn.Copy wksNew.Columns("T")
Case "Comments" 'Heading that goes to column U
rngCurrent.EntireColumn.Copy wksNew.Columns("U")
End Select
Next rngCurrent
Call Workbook_BeforeClose
End Sub
Private Sub workbook_open()
Application.OnKey "^{j}", "MyAddIn.xla!siRNAsequences10"
End Sub
'this will assign the macro to ctl+j
Private Sub Workbook_BeforeClose()
Application.OnKey "^{j}", ""
End Sub
'this will unassign the macro to ctl+j
Post by g***@yahoo.comMy two cents ...
1.
Sub test()
MsgBox Application.TemplatesPath
end sub
Then one directory above look for an addin folder. Put your add in
there
2.
Once you've stored the addin into the right folder you must register it
with Excel.
Tools->Addins
Check your add in to register it with Excel
3. I deal with the addin/not same workbook problem by opening a
template (or a workbook that's going to have the data) and then
accessing it as a variable
Sub LoadTemplateOrWorkbook
Dim book as Workbook
Set book = Workbooks.Open(Application.TemplatesPath +
"SomeTemplate.xlt")
book.Sheets("Somesheet").Visible = True ' Whatever just to show how to
access a sheeet
DoYourMacroHavingWorkbookArgument book
End Sub