[yankeesfan]

Im trying to select rows continus until a cell equals a certain value, acting as a select end so to speak then the selected values can be copyed onto another sheet. and sugestions??

 

[Zack Barresse]

Huh??

Edit: Please don't hijack other people's threads either. It's generally considered rude.

 

[JohnWill]

Even though it appears you're having the same problem, please start a new thread when you have a new issue. It's very difficult to keep two problems straight and who's working on what in a single thread.

I've created a new thread for your issue here.

Thanks for your cooperation.

 

[~Candy~]

Huh??

Edit: Please don't hijack other people's threads either. It's generally considered rude.

firefytr, in the future, just report posts, don't try to moderate them

Thanks

 

[yankeesfan]

Im new here sorry......

 

[bomb #21]

Hopefully this thread won't get closed while I'm in the process of posting a reply.

OK, let's say you have 1 -- 2 -- 3 -- I in A11:A14 on Sheet1.

The following code should copy A11:A13 to a newly added sheet. HTH.

Sub test()
Range("A11", Range("A" & WorksheetFunction.Match("I", Range("A:A"), 0) - 1)).Copy
Sheets.Add: ActiveSheet.Paste
End Sub

 

[Ziggy1]

how about this....it might need some massaging

' Macro1 1/4/2007 by Ziggy
'
Sub test()

Dim EndRng As String ' used to find last row
Dim Row1 As Integer 'begin row range
Dim Row2 As Integer 'end row range

Row1 = 2
Row2 = 1

Do Until EndRng = "A" 'loops until the value that you want to
'stop at is encountered

EndRng = Range("A" & Row2) ' loops down column

Row2 = Row2 + 1 ' adds 1 to increment down column

Loop

EndRng = Row1 & ":" & Row2 - 1 ' Creates full range to copy...
' I subtracted 1 but you can
' adjust depending on where you
' want to select

'Rows(EndRng).Select ' don't really need this one

Range(EndRng).Copy ' copies the range

Sheets.Add: ActiveSheet.Paste ' Adds new sheet and pastes the data


End Sub


I set it up assuming row one would be your heading, so it is not copied. If you want it to copy, then change the variable ROW1 to equal 1 instead of 2.

 

[yankeesfan]

This seems to work thx ziggy. But if i wanted to repeat this process how would i start the string when a cell has a certain character.

and is there a way to select the rows but only collum A

 

[yankeesfan]

Here is a samle of what in trying to extract. The letters in red is what i want to copy. So i would like to restart the string again for the next section. This sheet is all in colum A because it is imported from notepad..

Thx


---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 1

< Including Comment > Line name Line2

Program name = AB126-1A.H51 12/22/2006 10:45
PWB ID = ABIONICS C7055126-099 R:W/AA BGA
User ID =
Station = #1 FX1R-1 (FX-1R)

Pos. Component Comment Pack Type Pitch lane Use
LF- 19 C1016151-2493 RES,249 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 21 C1016151-4991 RES,4.99 K,1/16W,1%,0402 Tape 8mm 4mm(4*1) * Yes
LF- 23 C1016151-1243 RES,124 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 25 C1016151-4873 RES,487K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 27 1039920-212 CAP,2.2 UF,10V,20%,0805 Tape 8mm paper 4mm(4*1) * Yes
LF- 29 C1016151-8252 RES,82.5 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 31 C1016151-4992 RES,49.9 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 33 C1065309-S159 DIODE,MA4S159,4-PIN Tape 8mm 4mm(4*1) * Yes
LF- 35 C1016151-1003 RES,100 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
LF- 37 C1016151-6811 RES,6.81 K,1%,0402 Tape 8mm 4mm(4*1) * Yes
LF- 39 C1016151-1403 RES,140K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes

---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 2

< Including Comment > Line name Line2

Program name = AB126-1A.H51 12/22/2006 10:45
PWB ID = ABIONICS C7055126-099 R:W/AA BGA
User ID =
Station = #1 FX1R-1 (FX-1R)

Pos. Component Comment Pack Type Pitch lane Use

---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 3

< Including Comment > Line name Line2

Program name = AB126-1A.H51 12/22/2006 10:45
PWB ID = ABIONICS C7055126-099 R:W/AA BGA
User ID =
Station = #1 FX1R-1 (FX-1R)

Pos. Component Comment Pack Type Pitch lane Use
RF- 1 C1016151-2003 RES,200 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 3 C1016151-4751 RES,4.75 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 5 C1016151-1004 RES,1 M,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 7 C1034157-104 CAP,0.1uF,50V,20%,0805 Tape 8mm 4mm(4*1) * Yes
RF- 9 C1016151-10R0 RES,10 ohm,1/10W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 11 C1016151-1002 RES,10 K,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 13 C1054300-3904 XSTR,3904,40V,SOT-23 Tape 8mm 4mm(4*1) * Yes
RF- 15 C1039050-300 CAP,30 PF,50V,5%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 17 C1039155-102 CAP,1 NF,50V,5%,0402 Tape 8mm 4mm(4*1) * Yes
RF- 19 C1016151-8250 RES,825 ohm,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
RF- 21 C1016151-3400 RES,340 ohm,1/16W,1%,0402 Tape 8mm 2mm(2*1) * Yes
---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 4

< Including Comment > Line name Line2

Program name = AB126-1A.H51 12/22/2006 10:45
PWB ID = ABIONICS C7055126-099 R:W/AA BGA
User ID =
Station = #1 FX1R-1 (FX-1R)

Pos. Component Comment Pack Type Pitch lane Use

---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 5

< Including Comment > Line name Line2

Program name = AB126-1A.H52 12/22/2006 10:45
PWB ID = ABIONICS C7055126-099 R:W/AA BGA
User ID =
Station = #2 2050L-1 (2050L)

Pos. Component Comment Pack Type Pitch lane Use
F - 22 C1039229-001 CAP,0.1uF,-20/+80%,16V,SMD Tape 8mm 2mm(2*1) * Yes

 

[Ziggy1]

change this part to select the range in column A

EndRng = "A" & Row1 & ":" & "A" & Row2 - 1


I think I know what you mean for the other part. I have some examples I setup before for stripping headers out of a text file (or in Excel). I just have to dig it out and clean it up

 

[Jimmy the Hand]

Try this code:

Sub test()
    Dim Pattern As String
    Dim RIx As Long
    Dim Tgt As Worksheet, Src As Worksheet
    Dim c As Range
    
    Set Src = ActiveSheet
    Set Tgt = Worksheets.Add
    Src.Activate
    Do
        Pattern = InputBox("First letters? (Click cancel for exit.)")
        If Pattern = "" Then Exit Do
        For Each c In Src.Range("A1", Range("A" & Src.Rows.Count).End(xlUp)).Cells
            If InStr(c.Value, Pattern) = 1 Then c.Copy Tgt.Range("A" & Tgt.Rows.Count).End(xlUp).Offset(1)
            If (c.Value Like Pattern & "*") Then c.Copy Tgt.Range("A" & Tgt.Rows.Count).End(xlUp).Offset(1)
        Next
    Loop
End Sub

You see two lines starting with If. Any one of them will do, the other should be deleted or disabled. Zack will tell you which one is faster

Jimmy

 

[Zack Barresse]

Zack will tell you which one is faster

With a sample file I will.

 

[Jimmy the Hand]

With a sample file I will.

It's there, in post #6. All of them in Column "A". But I'm kind and post one, here

 

[Ziggy1]

This code is closer to what you are asking, it is built for something I need. I left some code in place which I disabled ( in case it serves a purpose to anyone else).

But it needs to be modified based on the data, I just don't have the time to make it match yours, these other way of doing it is to identify a constant with in the rows and then delete everything else. I have something for that also. Eg I see "YES" at the end of the rows.

What I have hear may look complicated, I will up load the spreadsheet also. I think it will give serve as a good example. Of course there are many ways to accomplish the task (probably with less code.

Paste data starting with ... ---- Feeder setup Sheet ---- 12/22/2006 10:47 Page 1

Option Explicit

Public Sub DataSort()

'Written by Ziggy Stouten April 9 - 2006

' this macro is written to format the E-mail that comes in via EDI elm mail
' the macro converts the Text which is in the form of a Text file in the body of an
' e-mail to a flat Excel file.

' Note the E-mail Text is pasted into Cell A1 of Sheet one exactly as it is,
' use ctrl-a to select all then copy/ paste to A

ActiveSheet.Unprotect

Dim CellVal As String
Dim Line1 As String ' first line row selector
Dim Line2 As String ' second line row selector
Dim Col1 As String ' Remains Static as declared

Dim Row1 As String ' First line to be read and formatted
Dim Row2 As Integer ' is the row for the sorted data
Dim Row3 As Integer ' Second line to be read and formatted
Dim CellChk As Integer ' Used to check the cell for character count
Dim rptDate As String ' Variable to extract date
Dim rptDateval As String ' Variable for Extracted Date

Dim SavePath As String
Dim Path As String

Path = Range("Path1").Text

SavePath = Path & "\NewModel.xls"

rptDateval = Range("a19").Value ' This is the cell that contains the date

rptDate = Mid(rptDateval, 19, 2) & "-" & Mid(rptDateval, 21, 2) & "-" & Mid(rptDateval, 23, 4)
Col1 = "A"

Row1 = 22
Row2 = 2
Row3 = 23
CellChk = 1

Do Until CellChk = 0 ' This checks the cell character length once it is zero the loop stops

Line1 = Range(Col1 & Row1).Value 'This is the default starting(LINE1) row for the report
'Line2 = Range(Col1 & Row3).Value 'This is the default starting (Line2) row for the report
' I disabled Line2 because it is for a 2 line segment that gets copied to a single line

'Model
CellChk = Len(Line1)
CellVal = Left(Line1, 10)
Range("C" & Row2).Value = CellVal

'If CellChk <> 0 Then need to add check for blank incase they forget to paste data

'D
CellVal = Mid(Line1, 26, 1)
Range("D" & Row2).Value = CellVal

'E
CellVal = Mid(Line1, 36, 1)
Range("E" & Row2).Value = CellVal

'F
CellVal = Mid(Line1, 43, 6)
Range("F" & Row2).Value = CellVal

'G
CellVal = Mid(Line1, 57, 4)
Range("G" & Row2).Value = CellVal

'H
CellVal = Mid(Line1, 63, 3)
Range("H" & Row2).Value = CellVal

'I
CellVal = Mid(Line1, 68, 3)
Range("I" & Row2).Value = CellVal

'J
CellVal = Mid(Line1, 73, 3)
Range("J" & Row2).Value = CellVal

'K
CellVal = Mid(Line1, 78, 5)
Range("K" & Row2).Value = CellVal

'L
CellVal = Mid(Line1, 88, 5)
Range("L" & Row2).Value = CellVal

'M
CellVal = Mid(Line1, 95, 3)
Range("M" & Row2).Value = CellVal

'N
CellVal = Mid(Line1, 105, 2)
Range("N" & Row2).Value = CellVal

'O
CellVal = Mid(Line1, 114, 1)
Range("O" & Row2).Value = CellVal

' Second line

'P
'CellVal = Mid(Line2, 40, 3)
'Range("P" & Row2).Value = CellVal

'Q
'CellVal = Mid(Line2, 47, 23)
'Range("Q" & Row2).Value = CellVal

'R
'CellVal = Mid(Line2, 78, 8)
'Range("R" & Row2).Value = CellVal

'S
'CellVal = Mid(Line2, 89, 2)
'Range("S" & Row2).Value = CellVal

'T
'CellVal = Mid(Line2, 93, 2)
'Range("T" & Row2).Value = CellVal

'U
'CellVal = Mid(Line2, 104, 7)
'Range("U" & Row2).Value = CellVal

'V
'CellVal = Mid(Line2, 117, 10)
'Range("V" & Row2).Value = CellVal

' increments rows to next lines of data to read
Row1 = Row1 + 3
Row2 = Row2 + 1 ' this is a single increment because it is for the formated data
Row3 = Row3 + 3

Loop

' Adds Column Headings

Range("C1").Value = "C1"
Range("D1").Value = "D1"
Range("E1").Value = "E1"
Range("F1").Value = "F1"
Range("G1").Value = "G1"
Range("H1").Value = "H1"
Range("I1").Value = "I1"
Range("J1").Value = "Hgt"
Range("K1").Value = "K1"
Range("L1").Value = "L1"
Range("M1").Value = "M1"
Range("N1").Value = "N1"
Range("O1").Value = "O1"
Range("P1").Value = "P1"
Range("Q1").Value = "Q1"
Range("R1").Value = "R1"
Range("S1").Value = "S1"
Range("T1").Value = "T"
Range("U1").Value = "U1"
Range("V1").Value = "V1"
Range("W1").Value = "W1"

Cells.EntireColumn.AutoFit

'Puts in the date stamp from the report Header

'goes to last cell in column and then up to 1st empty cell then shift over one and up
Range("c65536").End(xlUp).Offset(-1, 20).Select
'puts in formula in active cell
ActiveCell.FormulaR1C1 = rptDate
'select the formula
ActiveCell.Select
'copies formula
Selection.Copy

'selects column up and pastes formula
Range(Selection, Selection.End(xlUp)).Offset(1, 0).Select
'Paste Formula range
ActiveSheet.Paste

Range("W1").Value = "FileDate"

' Selects the formatted data and copies it to be pasted into a new workbook
Selection.CurrentRegion.Select
Selection.Copy

Workbooks.Add

ActiveSheet.Paste

Cells.EntireColumn.AutoFit

Application.DisplayAlerts = False ' disables the warning to over write the file
ActiveWorkbook.SaveAs Filename:= _
SavePath _
, FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = True
' Application.StatusBar = False
' Application.ScreenUpdating = True
ActiveWindow.Close 'close the saved book

'sets focus bac to macro book
ThisWorkbook.Activate

'Deletes the formatted range
Range("c:w").Clear

'Deletes the Unformatted data
Range("A12:A65536").Clear

' resets the Yellow color
With Range("A12")
.Interior.ColorIndex = 6
.Locked = False

End With

Range("A12").Activate

'Protects the workbook, but the area that the data is pasted to is Unlocked for pasting
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

 

[yankeesfan]

Here is both the original from note pad. and then the other is what my sheet should look like.

 

[Jimmy the Hand]

I almost said this was impossible. Then found something.
I'm off this thread for a while, but I verily recommend for anyone, who wants to work on the solution, to put the whole content of the source sheet back into a textfile. It will look far more ordered and comprehensible.
Better yet, I upload it for everyone's delight

 

[Ziggy1]

ok I put together this method, it uses the word "YES" as a key for the line and will delete all the other rows that do not contain "YES". Hopefully "YES" is a constant. If it isn't let me know the other possiibilities.

I did not go all the way as far as laying it out into your final layout.

I set the code using the tesxt file jimmy posted, which i gather he pulled from the excel file. I used the text importer to set the data into columns.

Sub DELrow()
'
' 1/07/2007 by ziggystouten
'

Dim FindX As Long
Dim FileToOpen As Variant

FileToOpen = Application _
.GetOpenFilename("Text Files (*.txt), *.txt")
If FileToOpen <> False Then
End If

Workbooks.OpenText FileToOpen, Origin:=xlWindows _
, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _
Array(Array(0, 9), Array(7, 2), Array(14, 2), Array(35, 2), Array(66, 2), Array(73, 2), _
Array(85, 2), Array(95, 2), Array(100, 2), Array(103, 9))

Cells.Select
Cells.EntireColumn.autofit
Rows("5:5").Select
Selection.Cut
Rows("1:1").Select
Selection.Insert Shift:=xlDown
Cells.Select
Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

Dim X As Long, Y As Range
Set Y = ActiveSheet.UsedRange.Rows
Application.ScreenUpdating = False
For X = Y.Rows.Count To 1 Step -1

FindText = Range("H" & X)

If FindText <> "Yes" Then
Y.Rows(X).EntireRow.Delete
End If
Next X

Rows("1:1").Select
Selection.Insert Shift:=xlDown
Range("A1") = "POS"
Range("B1") = "Component"
Range("C1") = "Comment"
Range("D1") = "Pack"
Range("E1") = "Type"
Range("F1") = "Pitch"
Range("G1") = "Lane"
Range("H1") = "Use"

' Columns("C:I").Select
' Selection.Insert Shift:=xlToRight

Cells.Select
Cells.EntireColumn.autofit
Range("A1:J1").Select

End Sub

 

[Ziggy1]

but of course that would be too easy, I forgot about the headings for each detail section.

Program name = AB126-1A.H51
PWB ID = ABIONICS C7055126-099 R:W/A
User ID =
Station = #1 FX1R-1 (FX-1R)

I'll pick a reference (constant) so I can get the header records, copy them beside each record, and then proceed with the delete action. The end result will be a flat file, that will be easier to work with.

 

[yankeesfan]

I am wondering the code in a macro to insert text in a unkown cell but is offset from my last row down 2 rows and over right 4 columns?? is there a way to do this


Second is there a code to check which is my last row that contains any character and if the next 5 rows are blank stop my operation???

Third is there a code to highlight every other row?????

 

[Ziggy1]

I am wondering the code in a macro to insert text in a unkown cell but is offset from my last row down 2 rows and over right 4 columns?? is there a way to do this

Public Sub FindlastRow()

Dim LastRow As Long

'goes to last cell in column and then up to last filled cell
Range("A65536").End(xlUp).Offset(0, 0).Select
LastRow = ActiveCell.Row

ActiveCell.Offset(2, 4).Select ' down 2 over 4

ActiveCell = "test"

End Sub