Change a Macro - Copy in Columns instead of copy in Rows

Y

ytayta555

HI , and a good day to all programmers

I have actually the next macro :

Sub AAACOLUMNS()
Application.ScreenUpdating = True

Dim FromWks1 As Worksheet
Dim DestWks As Worksheet
Dim NextRow As Long
Dim myCell As Range
Dim myRng1 As Range
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long
Dim i7 As Long


Set FromWks1 = Workbooks("DATABASE Gr VALUE.xls").Worksheets("1")
Set DestWks = Workbooks("RAMSES1.xls").Worksheets("1")
With FromWks1
Set myRng1 = .Range("A2000:T2000")
End With

With FromWks1

For i1 = 41 To 50
For i2 = i1 + 1 To 51
For i3 = i2 + 1 To 52
For i4 = i3 + 1 To 53
For i5 = i4 + 1 To 54
For i6 = i5 + 1 To 55
For i7 = i6 + 1 To 56


.Range("A2001:A3635") = .Range(Cells("1", i1), Cells
("1635", i1)).Value
.Range("B2001:B3635") = .Range(Cells("1", i2), Cells
("1635", i2)).Value
.Range("C2001:C3635") = .Range(Cells("1", i3), Cells
("1635", i3)).Value
.Range("D2001:D3635") = .Range(Cells("1", i4), Cells
("1635", i4)).Value
.Range("E2001:E3635") = .Range(Cells("1", i5), Cells
("1635", i5)).Value
.Range("F2001:F3635") = .Range(Cells("1", i6), Cells
("1635", i6)).Value
.Range("G2001:G3635") = .Range(Cells("1", i7), Cells
("1635", i7)).Value

For Each myCell In myRng1.Cells
If myCell.Value = "OK" Then
With FromWks1
.Range("A" & myCell.Row).AutoFill _
Destination:=.Range("A" & myCell.Row & ":G" &
myCell.Row), Type:=xlFillDefault
.Range("A1:A7").Copy
.Range("DA" & myCell.Row & ":DG" &
myCell.Row).PasteSpecial , Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = False
With DestWks
NextRow = .Cells(.Rows.Count, "CY").End(xlUp).Row + 1
myCell.EntireRow.Copy
.Cells(NextRow, "A").PasteSpecial , Paste:=xlPasteValues
End With
Range("CX" & myCell.Row & ":AJ" & myCell.Row).ClearContents
End If
Next myCell
Application.CutCopyMode = False

Next i7
Next i6
Next i5
Next i4
Next i3
Next i2
Next i1

End With
Application.ScreenUpdating = True
End Sub
_ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ __ __ _

1) What I need now is , to copy and to do autofill in Columns ,
not in Rows ; so , I have myRng1 = .Range("A2000:T2000")
If myCell.Value = "OK" Then _ then to do autofill from
row 2000 & myCell to 3635 & myCell , instead of .........
.... .Range("A" & myCell.Row).AutoFill _
Destination:=.Range("A" & myCell.Row & ":G" & myCell.Row),
Type:=xlFillDefault
Actually , this code do the autofill in myCell.Row

2) After this autofill , the code must copy entire Column (not
Row!) ,
( myCell Column )
and copy it in the second workbook (named "RAMSES1.xls"),
in first column , then in second , from Column A to Column IV
(I use xl 2003) ;

2 a ) When the first worksheet is full (column265) , to copy it in
second
worksheet (named "2") , in column A , and so on ...

It mean , what I need is , what code was done from past time until now
in Rows , to do it in Columns !..!...

Maybe I shall came back later with a last question in my problem ;
Please very much to provide me this changes in this code
 
J

joel

Sub AAACOLUMNS()
Application.ScreenUpdating = True

Dim FromWks1 As Worksheet
Dim DestWks As Worksheet
Dim NextRow As Long
Dim myCell As Range
Dim myRng1 As Range
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long
Dim i7 As Long


Set FromWks1 = Workbooks("DATABASE Gr VALUE.xls").Worksheets("1")
Set Destbk = Workbooks("RAMSES1.xls")
DestCol = 1
With FromWks1
Set myRng1 = .Range("A2000:T2000")
End With

With FromWks1

For i1 = 41 To 50
For i2 = i1 + 1 To 51
For i3 = i2 + 1 To 52
For i4 = i3 + 1 To 53
For i5 = i4 + 1 To 54
For i6 = i5 + 1 To 55
For i7 = i6 + 1 To 56


.Range("A2001:A3635") = .Range(Cells("1", i1), _
Cells("1635", i1)).Value
.Range("B2001:B3635") = .Range(Cells("1", i2), _
Cells("1635", i2)).Value
.Range("C2001:C3635") = .Range(Cells("1", i3), _
Cells("1635", i3)).Value
.Range("D2001:D3635") = .Range(Cells("1", i4), _
Cells("1635", i4)).Value
.Range("E2001:E3635") = .Range(Cells("1", i5), _
Cells("1635", i5)).Value
.Range("F2001:F3635") = .Range(Cells("1", i6), _
Cells("1635", i6)).Value
.Range("G2001:G3635") = .Range(Cells("1", i7), _
Cells("1635", i7)).Value

First = True
For Each myCell In myRng1.Cells
If myCell.Value = "OK" Then
With FromWks1
.Cells(myCell.Row, myCell.Column).Copy _
Destination:= _
.Range(.Cells(myCell.Row, myCell.Column), _
.Cells(3635, myCell.Column))

If DestCol = 1 Then
With Destbk
Destbk.Sheets.Add _
after:=.Sheets(.Sheets.Count)
Set DestWks = ActiveSheet
End With
End If

.Range(.Cells(myCell.Row, myCell.Column), _
.Cells(3635, myCell.Column)).Copy
DestWks.Cells(1, DestCol).PasteSpecial , _
Paste:=xlPasteValues
DestCol = DestCol + 1
If DestCol > Columns.Count Then
DestCol = 1
End If

'do this code once
If First = True Then
.Range("A1:A7").Copy
.Range("DA" & myCell.Row & ":DG" & _
myCell.Row).PasteSpecial , _
Paste:=xlPasteValues, _
Transpose:=True
First = False
End If
End With
Application.CutCopyMode = False
Range("CX" & myCell.Row & _
":AJ" & myCell.Row).ClearContents
End If
Next myCell
Application.CutCopyMode = False

Next i7
Next i6
Next i5
Next i4
Next i3
Next i2
Next i1

End With
Application.ScreenUpdating = True
End Sub
 
Y

ytayta555

Thank you so much , so glad to meet you again , old saviour

I changed Dim NextRow As Long with Dim NextColumn As Long,
and next code work perfect for me , except a part :

Sub AAACOLUMNSNEW()
Application.ScreenUpdating = True

Dim FromWks1 As Worksheet
Dim DestWks As Worksheet
Dim NextColumn As Long
Dim myCell As Range
Dim myRng1 As Range
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long
Dim i7 As Long


Set FromWks1 = Workbooks("DATABASE Gr VALUE.xls").Worksheets("1")
Set DestWks = Workbooks("RAMSES1.xls").Worksheets("1")
With FromWks1
Set myRng1 = .Range("U2000:AN2000")
End With
With FromWks1
For i1 = 41 To 50
For i2 = i1 + 1 To 51
For i3 = i2 + 1 To 52
For i4 = i3 + 1 To 53
For i5 = i4 + 1 To 54
For i6 = i5 + 1 To 55
For i7 = i6 + 1 To 56
.Range("A2001:A3635") = .Range(Cells("1", i1), _
Cells("1635", i1)).Value
.Range("B2001:B3635") = .Range(Cells("1", i2), _
Cells("1635", i2)).Value
.Range("C2001:C3635") = .Range(Cells("1", i3), _
Cells("1635", i3)).Value
.Range("D2001:D3635") = .Range(Cells("1", i4), _
Cells("1635", i4)).Value
.Range("E2001:E3635") = .Range(Cells("1", i5), _
Cells("1635", i5)).Value
.Range("F2001:F3635") = .Range(Cells("1", i6), _
Cells("1635", i6)).Value
.Range("G2001:G3635") = .Range(Cells("1", i7), _
Cells("1635", i7)).Value

For Each myCell In myRng1.Cells
If myCell.Value = "OK" Then
With FromWks1
.Cells(myCell.Row, myCell.Column).AutoFill _
Destination:=.Range(.Cells(myCell.Row,
myCell.Column), .Cells(3635, myCell.Column))
.Range("A2001:G2001").Copy
.Range(.Cells("3641", myCell.Column), .Cells
("3647", myCell.Column)).PasteSpecial , _
Paste:=xlPasteValues, _
Transpose:=True
End With
Application.CutCopyMode = False
With DestWks
NextColumn = .Cells("1", .Columns.Count).Column +
1
myCell.EntireColumn.Copy
.Cells("1", NextColumn).PasteSpecial ,
Paste:=xlPasteValues
End With
.Range(.Cells("2001", myCell.Column), .Cells("3647",
myCell.Column)).ClearContents
End If
Next myCell
Application.CutCopyMode = False
Next i7
Next i6
Next i5
Next i4
Next i3
Next i2
Next i1
End With
Application.ScreenUpdating = True
End Sub

Absolute all my code work perfect , except this part :

With DestWks
NextColumn = .Cells("1", .Columns.Count).Column + 1
myCell.EntireColumn.Copy
.Cells("1", NextColumn).PasteSpecial , Paste:=xlPasteValues
End With

The code don't copy in DestWks in first column , from Row 1 ,
then in second Column (B), ......... to column IV , then to add a new
sheet (or copy in a next yet existing one , in first column ) , .....

Please again for help .
 
Y

ytayta555

Absolute all my code work perfect , except this part :
Click to expand...

I tried and so :

For Each myCell In myRng1.Cells
If myCell.Value = "OK" Then
With FromWks1
.Cells(myCell.Row, myCell.Column).AutoFill _
Destination:=.Range(.Cells(myCell.Row,
myCell.Column), .Cells(3635, myCell.Column))
.Range("A2001:G2001").Copy
.Range(.Cells("3641", myCell.Column), .Cells
("3647", myCell.Column)).PasteSpecial , _
Paste:=xlPasteValues, _
Transpose:=True
End With
Application.CutCopyMode = False

If DestCol = 1 Then
With DestWks
DestWks.Sheets.Add _
after:=.Sheets(.Sheet.Count)
Set DestWks = ActiveSheet
End If
DestWks.Cells(1, DestCol).PasteSpecial , _
Paste:=xlPasteValues
DestCol = DestCol + 1
If DestCol > Columns.Count Then
DestCol = 1
End If
End With
.Range(.Cells("2001", myCell.Column), .Cells
("3647", myCell.Column)).ClearContents
End If

but is highlighting the next part :
after:=.Sheets(.Sheet.Count) , word
Sheet in (.Sheet.Count) .
 
J

joel

I don't want to have 30 posting again like the last time I helped you. The
code I posted would of done everything. You keep on going backwards rather
than forward in solving the problems. work with my code and let me k now what
the problems are. The method you are using worn't work for multiple pages.
Compare my code carefully against your code and you will see all the changes
I made that you left out.
 
Y

ytayta555

OK OK , I'll work , but only this part solve my problem :
Absolute all my code work perfect , except this part :

With DestWks
NextColumn = .Cells("1", .Columns.Count).Column + 1
myCell.EntireColumn.Copy
.Cells("1", NextColumn).PasteSpecial , Paste:=xlPasteValues
End With

It is OK and without Add-ing another sheets , only to paste in
DestWks ,
Worksheet("1") , in Columns .
Thank you so much
 
J

joel

Your request asked for multiple worksheets So I had to do the following

1) Create the variable for the workbook

Set Destbk = Workbooks("RAMSES1.xls")

2) Use variable DestCol to keep track of the column we are writing to rather
than keep on using END() method which causes problems when you get to the
last column

3) When DestCol gets to 256 set it back to one and create a new worksheet.
 
Y

ytayta555

Your request asked for multiple worksheets So I had to do the following
Click to expand...

I GET IT !!

I worked with your code , but forever highlighting the next part :
after:=.Sheets(.Sheet.Count) , the word ,,Sheet,, from
(.Sheet.Count) .
(I tried and with ,,Sheets" ... )

So , why I needed to put the result in entire Column , was to check
then
the data , but , now , I inserted a UDF function which show me
the result I need ; with Transpose method , I could still keep my
old code , and the code copy the results I need in rows (I'll have
not
more then 65536 results )
UDF : http://groups.google.ro/group/micro...d/thread/5e812da2f57da2c7/9e952690a05b5ce5?q=

Here is my code :

Sub AAACOLUMNSOK()
Application.ScreenUpdating = True

Dim FromWks1 As Worksheet
Dim DestWks As Worksheet
Dim NextRow As Long
Dim myCell As Range
Dim myRng1 As Range
Dim i1 As Long
Dim i2 As Long
Dim i3 As Long
Dim i4 As Long
Dim i5 As Long
Dim i6 As Long
Dim i7 As Long

Set FromWks1 = Workbooks("DATABASE Gr VALUE.xls").Worksheets("1")
Set DestWks = Workbooks("RAMSES1.xls").Worksheets("1")

With FromWks1
Set myRng1 = .Range("U2000:AN2000")
End With

With FromWks1

For i1 = 41 To 50
For i2 = i1 + 1 To 51
For i3 = i2 + 1 To 52
For i4 = i3 + 1 To 53
For i5 = i4 + 1 To 54
For i6 = i5 + 1 To 55
For i7 = i6 + 1 To 56


.Range("A2001:A3635") = .Range(Cells("1", i1), _
Cells("1635", i1)).Value
.Range("B2001:B3635") = .Range(Cells("1", i2), _
Cells("1635", i2)).Value
.Range("C2001:C3635") = .Range(Cells("1", i3), _
Cells("1635", i3)).Value
.Range("D2001:D3635") = .Range(Cells("1", i4), _
Cells("1635", i4)).Value
.Range("E2001:E3635") = .Range(Cells("1", i5), _
Cells("1635", i5)).Value
.Range("F2001:F3635") = .Range(Cells("1", i6), _
Cells("1635", i6)).Value
.Range("G2001:G3635") = .Range(Cells("1", i7), _
Cells("1635", i7)).Value

For Each myCell In myRng1.Cells
If myCell.Value = "OK" Then
With FromWks1
.Cells(myCell.Row, myCell.Column).AutoFill _
Destination:=.Range(.Cells(myCell.Row,
myCell.Column), .Cells(3635, myCell.Column))
.Range("A2001:G2001").Copy
.Range(.Cells("3640", myCell.Column), .Cells
("3647", myCell.Column)).PasteSpecial , _
Paste:=xlPasteValues, _
Transpose:=True
.Range("A2000:C2000").Copy
.Cells("3636", myCell.Column).PasteSpecial , _
Paste:=xlPasteValues, _
Transpose:=True
myCell.Offset(-3, 0).FormulaR1C1 = "=cuR(R[3]
C:R[55]C)"
End With
Application.CutCopyMode = False
With FromWks1
.Range(.Cells("1997", myCell.Column), .Cells("2050",
myCell.Column)).Copy
End With
With DestWks
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
.Cells(NextRow, "A").PasteSpecial ,
Paste:=xlPasteValues, _
Transpose:=True
End With
.Range(.Cells("2001", myCell.Column), .Cells("3633",
myCell.Column)).ClearContents
myCell.Offset(-3, 0).ClearContents
End If
Next myCell

Application.CutCopyMode = False
Next i7
Next i6
Next i5
Next i4
Next i3
Next i2
Next i1

End With
Application.ScreenUpdating = True
End Sub

Thank you very much for helped me again ,
HAVE A GREAT WEEKEND .
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Word macro that can call cells out of Excel for a find and replace 0
Displaing result in Entire worksheet 4
FIND method , versus FOR EACH ... 7
Handle a value from a Range instead of value of a Cell 8
I need some changes in a code 5
Some changes in a Macro .. 4
Perfect Macro Combinations 5
DECLARE VARIABLES PROBLEM 7

Top