PDA

View Full Version : Solved: copying data error



kwik10z
11-09-2007, 07:19 AM
I am beginner with visual basic or any code for that matter, so bare with me if my question(s) dont make any sense or are just stupid!! sorrry in advance.

but any help would be greatly appreciated.

I am trying to scan through some data and copy certain lines over to a new work book. I got it working but it doesn't seem to be working correctly 100%

It is suppose to scan through column 1 and recognize a ";" and the number "25" as the first character(s), and if it finds one, copy each row containing those characters to a seperate workbook.

It does just that, but it seems to copy the same row every time it finds a semicolon or a 25.

here is the code i have:

Sub PnP_Column1_FindSemiColon()

Dim oWB1 As Workbook ' input worksheet
Dim oWB2 As Workbook ' output worksheet

Dim bRet As Boolean
Dim cRet As Boolean

Set oWB1 = ActiveWorkbook
Set oWB2 = Workbooks.Add

Dim i1 As Long
Dim i2 As Long

Dim arSemiColonAdd() As String
Dim arFindNo25Add() As String
Dim iRow

bRet = FindAll(";", oWB1.Sheets(1), "A:A", arSemiColonAdd)
cRet = FindAll("25", oWB1.Sheets(1), "A:A", arFindNo25Add)

i2 = 1
If bRet = True Then

For i1 = 1 To UBound(arSemiColonAdd)
i2 = i2 + 1
iRow = Right(arSemiColonAdd(i1), Len(arSemiColonAdd(i1)) - InStrRev(arSemiColonAdd(i1), "$"))
oWB1.Sheets(1).Rows(iRow).EntireRow.Copy Destination:=oWB2.Sheets(1).Range("A" & i2)
Next i1

End If

If cRet = True Then

For il = 1 To UBound(arFindNo25Add)
i2 = i2 + 1
iRow = Right(arFindNo25Add(i1), Len(arFindNo25Add(i1)) - InStrRev(arFindNo25Add(i1), "$"))
oWB1.Sheets(1).Rows(iRow).EntireRow.Copy Destination:=oWB2.Sheets(1).Range("A" & i2)
Next il


End If
End Sub

The FindAll function (a sub-routine i have) seems to be doing its job, just it just seems to duplicate the rows it finds when they should all be somewhat different.

as in:


25 1 270 0.45 1.527 J1 WM7676
25 1 90 1.8 0.974 J2 WM7676
25 1 270 2.7 1.527 J3 WM7676
25 1 90 4.05 0.974 J4 WM7676
25 1 270 4.95 1.527 J5 WM7676
25 1 90 6.3 0.974 J6 WM7676
25 1 270 7.2 1.527 J7 WM7676
25 1 90 8.55 0.974 J8 WM7676 <--copies this row only for some reason

but instead i get:

25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676
25 1 90 8.55 0.974 J8 WM7676


can anyone see the problem??

Thanks

Bob Phillips
11-09-2007, 07:42 AM
Where is the semi-colon in that data?

What is FindAll?

How about just posting the workbook?

kwik10z
11-09-2007, 08:08 AM
Where is the semi-colon in that data?

What is FindAll?

How about just posting the workbook?

The semi-colon is the first character in some of the rows of the workbook indicating a comment.

FindAll is a routine that a friend wrote up, and can be found here....

' FindAll function
Function FindAll(ByVal sText As String, ByRef oSht As Worksheet, ByRef sRange As String, ByRef arMatches() As String) As Boolean
' --------------------------------------------------------------------------------------------------------------
' FindAll - To find all instances of the1 given string and return the row numbers.
' If there are not any matches the function will return false
' --------------------------------------------------------------------------------------------------------------
On Error GoTo Err_Trap
Dim rFnd As Range ' Range Object
Dim iArr As Integer ' Counter for Array
Dim rFirstAddress ' Address of the First Find
' -----------------
' Clear the Array
' -----------------
Erase arMatches
Set rFnd = oSht.Range(sRange).Find(What:=sText, LookIn:=xlValues, LookAt:=xlPart)
If Not rFnd Is Nothing Then
rFirstAddress = rFnd.Address
Do Until rFnd Is Nothing
iArr = iArr + 1
ReDim Preserve arMatches(iArr)
arMatches(iArr) = rFnd.Address ' rFnd.Row ' Store the Row where the text is found
Set rFnd = oSht.Range(sRange).FindNext(rFnd)
If rFnd.Address = rFirstAddress Then Exit Do ' Do not allow wrapped search
Loop
FindAll = True
Else
' ----------------------
' No Value is Found
' ----------------------
FindAll = False
End If

' -----------------------
' Error Handling
' -----------------------
Err_Trap:
If Err <> 0 Then
MsgBox Err.Number & " " & Err.Description, vbInformation, "Find All"
Err.Clear
FindAll = False
End If
Exit Function
End Function

kwik10z
11-09-2007, 08:09 AM
i am trying to figure out how to post the workbook so it is legible.....

the way i tried it, it came out all screwed up! please be patient

Norie
11-09-2007, 08:10 AM
I don't see any semi-colons in the data you posted.:confused:

kwik10z
11-09-2007, 08:12 AM
i havent posted data....what you are looking at is the FindAll function.

im working on posting the data now!!

kwik10z
11-09-2007, 08:19 AM
7245

can you get that?

notice the semi-colon and the number 25 are in column 1 of the datasheet. I need the macro to scan each row in column 1 and if it notices one of them two values (; and 25) copy each and every line that contains those values to a seperate workbook/worksheet.

It sort of does that now, but it seems to the copy the same line every time!

kwik10z
11-09-2007, 09:06 AM
please?? anyone?

Bob Phillips
11-09-2007, 09:27 AM
That code is far too obscure for me to work thtrough.

Try this



Public Sub Test()
Dim rng As Range
Dim LastRow As Long
Dim oWB As Workbook

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

Set oWB = Workbooks.Add
Set rng = .Range("A1").Resize(LastRow)
rng.AutoFilter field:=1, Criteria1:="=;*", Operator:=xlOr, Criteria2:=25
rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy oWB.Worksheets(1).Range("A1")
oWB.Worksheets(1).Columns.AutoFit
rng.AutoFilter

Set rng = Nothing
End With
End Sub

kwik10z
11-09-2007, 10:39 AM
That code is far too obscure for me to work thtrough.

Try this



Public Sub Test()
Dim rng As Range
Dim LastRow As Long
Dim oWB As Workbook

With ActiveSheet

LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row

Set oWB = Workbooks.Add
Set rng = .Range("A1").Resize(LastRow)
rng.AutoFilter field:=1, Criteria1:="=;*", Operator:=xlOr, Criteria2:=25
rng.SpecialCells(xlCellTypeVisible).EntireRow.Copy oWB.Worksheets(1).Range("A1")
oWB.Worksheets(1).Columns.AutoFit
rng.AutoFilter

Set rng = Nothing
End With
End Sub



*Edit* I tried it, and it seems to do the job! thanks a ton man, your the man!

There are a few more steps that i need to complete to finish my project completely, if i came back with more questions, would you mind helping me out?

Bob Phillips
11-09-2007, 10:49 AM
Of course not, that is what the forum is for.

Might be best to start a new thread for you next question and mark this as solved.