PDA

View Full Version : Solved: Copy results to sheet2



tqm1
06-13-2007, 04:17 AM
Dear Experts

In Listbox, I get required data against given Date with following codes.

These codes work fine to data into Listbox.

But now I want copy required data to Sheet2.

Please modify codes



Private Sub CommandButton1_Click()
Dim c As Range
Dim sDate As Date
Dim ws As Worksheet
Set ws = Worksheets("weights")
sDate = Me.TextBox1.Value
ListBox1.CLEAR

For Each c In ws.Range("E:E")
If c.Value = sDate Then
With ListBox1
.AddItem Format(ws.Cells(c.Row, "E").Value, "dd-mm-yy")
.List(.ListCount - 1, 1) = ws.Cells(c.Row, "B").Value
.List(.ListCount - 1, 2) = ws.Cells(c.Row, "J").Value
.List(.ListCount - 1, 3) = ws.Cells(c.Row, "K").Value
.List(.ListCount - 1, 4) = ws.Cells(c.Row, "G").Value
.List(.ListCount - 1, 5) = ws.Cells(c.Row, "F").Value
.List(.ListCount - 1, 6) = ws.Cells(c.Row, "N").Value
.List(.ListCount - 1, 7) = ws.Cells(c.Row, "O").Value
.List(.ListCount - 1, 8) = ws.Cells(c.Row, "M").Value
.List(.ListCount - 1, 9) = ws.Cells(c.Row, "D").Value
End With
End If
Next c
End Sub

Bob Phillips
06-13-2007, 04:30 AM
Private Sub CommandButton1_Click()
Dim c As Range
Dim sDate As Date
Dim ws As Worksheet
Dim iRow As Long

Set ws = Worksheets("weights")
sDate = Me.TextBox1.Value

With Worksheets("Sheet2")
iRow = 1
For Each c In ws.Range("E:E")
If c.Value = sDate Then
.Cells(iRow, "A").Value = Format(ws.Cells(c.Row, "E").Value, "dd-mm-yy")
.Cells(iRow, "B").Value = ws.Cells(c.Row, "B").Value
.Cells(iRow, "C").Value = ws.Cells(c.Row, "J").Value
.Cells(iRow, "D").Value = ws.Cells(c.Row, "K").Value
.Cells(iRow, "E").Value = ws.Cells(c.Row, "G").Value
.Cells(iRow, "F").Value = ws.Cells(c.Row, "F").Value
.Cells(iRow, "G").Value = ws.Cells(c.Row, "N").Value
.Cells(iRow, "H").Value = ws.Cells(c.Row, "O").Value
.Cells(iRow, "I").Value = ws.Cells(c.Row, "M").Value
.Cells(iRow, "J").Value = ws.Cells(c.Row, "D").Value
End If
Next c
iRow = iRow + 1
End With
End Sub

tqm1
06-13-2007, 05:21 AM
Dear Sir,

Your codes copy only the last row of data to first row.
I made some modifications as follows.
Now every thing is fine.

I changed the location of this line
iRow = iRow + 1



Private Sub CommandButton1_Click()
Dim c As Range
Dim sDate As Date
Dim ws As Worksheet
Dim iRow As Long

Set ws = Worksheets("weights")
sDate = Me.TextBox1.Value

Sheets("sheet2").Select
Selection.Clear

With Worksheets("Sheet2")
iRow = 1
For Each c In ws.Range("E:E")
If c.Value = sDate Then
.Cells(iRow, "A").Value = Format(ws.Cells(c.Row, "E").Value, "dd-mm-yy")
.Cells(iRow, "B").Value = ws.Cells(c.Row, "B").Value
.Cells(iRow, "C").Value = ws.Cells(c.Row, "J").Value
.Cells(iRow, "D").Value = ws.Cells(c.Row, "K").Value
.Cells(iRow, "E").Value = ws.Cells(c.Row, "G").Value
.Cells(iRow, "F").Value = ws.Cells(c.Row, "F").Value
.Cells(iRow, "G").Value = ws.Cells(c.Row, "N").Value
.Cells(iRow, "H").Value = ws.Cells(c.Row, "O").Value
.Cells(iRow, "I").Value = ws.Cells(c.Row, "M").Value
.Cells(iRow, "J").Value = ws.Cells(c.Row, "D").Value
End If
iRow = iRow + 1
Next c

End With
Unload Me
Sheets("sheet2").Activate
'sort the sheet
Cells.Select
Selection.Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("E18").Select
End Sub