Column not copying
 

HI all,

Having probs with my code. It isnt copying the column 6 part of m
workbook. It copies column 2 but not column 6. Any ideas? Also, it run
particularly slow, is there a way to speed up this wonderfuf
process?????

Cheers!!!

Private Sub CommandButton1_Click()
CopyData Range("C10:C18"), "BASE MACHINE"
CopyData Range("C34:C103"), "CONTROL INCLUSIONS - UNIT 1"
CopyData Range("C108:C117"), "FEEDER INCLUSIONS - UNIT 1"
CopyData Range("C122:C179"), "FOLDING UNIT INCLUSIONS - UNIT 1"
End Sub
Private Sub CopyData(rngC As Range, Target As String)
Dim rng As Range, cell As Range
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range
Dim nrow As Long, rw As Long
Dim Sh As Worksheet
nrow = Application.CountIf(rngC, "0")
If nrow = 0 Then Exit Sub
Set Sh = Worksheets("sheet1")
Set rng = Sh.Columns(1).Find(What:=Target, _
After:=Sh.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If rng Is Nothing Then
MsgBox Target & " Not found"
Exit Sub
End If
Set rng3 = rng
rng.Offset(1, 0).ClearContents
If Application.CountA(rng3) 2 Then
Else
Set rng3 = rng.Offset(2, 0)
End If
rw = rng3.Row
rng3.Resize(nrow * 2, 1).EntireRow.Insert
For Each cell In rngC
If Not IsEmpty(cell) Then
If IsNumeric(cell) Then
If cell 0 Then
'Cells(cell.Row, 1).Resize(1, 2).Copy _
'Destination:=Sh.Cells(rw, 1)
Cells(cell.Row, 6).Copy
Sh.Cells(rw, "D").PasteSpecial Paste:=xlPasteValues
Cells(cell.Row, 2).Copy
Sh.Cells(rw, "B").PasteSpecial Paste:=xlPasteValues
rw = rw + 2
End If
End If
End If
Next
End Su

--
Message posted from http://www.ExcelForum.com

Column not copying
 

if you can send the worksheet and instructions, I will do
it for you.
See my samples at:
http://au.geocities.com/excelmarksway
http://www.geocities.com/excelmarksway

regards
Mark


-----Original Message-----
HI all,

Having probs with my code. It isnt copying the column 6
part of my
workbook. It copies column 2 but not column 6. Any ideas?
Also, it runs
particularly slow, is there a way to speed up this
wonderfufl
process?????

Cheers!!!

Private Sub CommandButton1_Click()
CopyData Range("C10:C18"), "BASE MACHINE"
CopyData Range("C34:C103"), "CONTROL INCLUSIONS - UNIT 1"
CopyData Range("C108:C117"), "FEEDER INCLUSIONS - UNIT 1"
CopyData Range("C122:C179"), "FOLDING UNIT INCLUSIONS -
UNIT 1"
End Sub
Private Sub CopyData(rngC As Range, Target As String)
Dim rng As Range, cell As Range
Dim rng1 As Range, rng2 As Range
Dim rng3 As Range
Dim nrow As Long, rw As Long
Dim Sh As Worksheet
nrow = Application.CountIf(rngC, "0")
If nrow = 0 Then Exit Sub
Set Sh = Worksheets("sheet1")
Set rng = Sh.Columns(1).Find(What:=Target, _
After:=Sh.Range("A1"), _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If rng Is Nothing Then
MsgBox Target & " Not found"
Exit Sub
End If
Set rng3 = rng
rng.Offset(1, 0).ClearContents
If Application.CountA(rng3) 2 Then
Else
Set rng3 = rng.Offset(2, 0)
End If
rw = rng3.Row
rng3.Resize(nrow * 2, 1).EntireRow.Insert
For Each cell In rngC
If Not IsEmpty(cell) Then
If IsNumeric(cell) Then
If cell 0 Then
'Cells(cell.Row, 1).Resize(1, 2).Copy _
'Destination:=Sh.Cells(rw, 1)
Cells(cell.Row, 6).Copy
Sh.Cells(rw, "D").PasteSpecial Paste:=xlPasteValues
Cells(cell.Row, 2).Copy
Sh.Cells(rw, "B").PasteSpecial Paste:=xlPasteValues
rw = rw + 2
End If
End If
End If
Next
End Sub


---
Message posted from http://www.ExcelForum.com/

.

Column not copying
 

Mark,

Thank you so much!!! I have sent my book to your listed e-mail address.
You can reply direct if you like.

cheers!!!!


---
Message posted from http://www.ExcelForum.com/