|
copying some rows and columns
Hi all,
Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Hi
I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Per,
Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht ... Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Jack,
I am glad you learned a bit from my code. If you change the code to copy row 1 also and paste starting in row 1, the textbox will not be copied, neither will the content of the textbox. You can place the content of the textbox in the underlying cell. To do that, enter design mode, and right click a textbox Properties Find LinkedCell property, and enter the cell address, eg. A1, then you just change the code to copy/paste starting at row 1 .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") Hopes this helps. .... Per "Jack Sons" skrev i meddelelsen ... Per, Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht ... Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Per,
If you change the code to copy row 1 also and paste starting in row 1 I did this With TargetSh .Range("DM1:DM" & eindrij).AutoFilter field:=1, Criteria1:="<x" .Range("A1:C" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") .Range("F1:F" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N1") .Range("AA1:AA" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O1") ... .Range("DM1:DM" & eindrij).AutoFilter End With but then the text boxes come with the cells of row 1 of TargetSh. I got rid of them with DestSh.Shapes("resteert").Select Selection.Delete DestSh.Shapes("betaald").Select Selection.Delete DestSh.Shapes("legenda_1").Select Selection.Delete DestSh.Shapes("L").Select Selection.Delete which is rather clumsy, I'm afraid (better: I'm sure). What now? Jack. "Per Jessen" schreef in bericht ... Jack, I am glad you learned a bit from my code. If you change the code to copy row 1 also and paste starting in row 1, the textbox will not be copied, neither will the content of the textbox. You can place the content of the textbox in the underlying cell. To do that, enter design mode, and right click a textbox Properties Find LinkedCell property, and enter the cell address, eg. A1, then you just change the code to copy/paste starting at row 1 .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") Hopes this helps. ... Per "Jack Sons" skrev i meddelelsen ... Per, Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht ... Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Jack,
You are close, but no need to select the shapes: DestSh.Shapes("resteert").Delete DestSh.Shapes("betaald").Delete DestSh.Shapes("legenda_1").Delete DestSh.Shapes("L").Delete Per "Jack Sons" skrev i meddelelsen ... Per, If you change the code to copy row 1 also and paste starting in row 1 I did this With TargetSh .Range("DM1:DM" & eindrij).AutoFilter field:=1, Criteria1:="<x" .Range("A1:C" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") .Range("F1:F" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N1") .Range("AA1:AA" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O1") ... .Range("DM1:DM" & eindrij).AutoFilter End With but then the text boxes come with the cells of row 1 of TargetSh. I got rid of them with DestSh.Shapes("resteert").Select Selection.Delete DestSh.Shapes("betaald").Select Selection.Delete DestSh.Shapes("legenda_1").Select Selection.Delete DestSh.Shapes("L").Select Selection.Delete which is rather clumsy, I'm afraid (better: I'm sure). What now? Jack. "Per Jessen" schreef in bericht ... Jack, I am glad you learned a bit from my code. If you change the code to copy row 1 also and paste starting in row 1, the textbox will not be copied, neither will the content of the textbox. You can place the content of the textbox in the underlying cell. To do that, enter design mode, and right click a textbox Properties Find LinkedCell property, and enter the cell address, eg. A1, then you just change the code to copy/paste starting at row 1 .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") Hopes this helps. ... Per "Jack Sons" skrev i meddelelsen ... Per, Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht ... Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Yes Per, I used that, thanks.
Now I would like to use nice compact and fast executing code for the following complex conditions. Row 1 contains headers. Cells in colums D to J (from row 2 downwards, as far below as there are names in column A) contain dates or nothing. In each row I want in column K the "highest" (most future) date but in bold and red if it is a future date of colums I or J in regular and black if is a future date of colums D to H in bold and blue if it is a date in the past and the rows with a bold and red date in column K sorted ascending to the dates in column K the rows with a ragular and black date in column K sorted ascending to the dates in column K the rows with a bold and blue date in column K sorted ascending to the dates in column K So column K will look like a red, blach and blue flag, like shown below (hope it will show after sending it over internet, colors are red for the first four dates, black for the following three and blue for the last five). 8 oktober 2009 14 oktober 2009 9 november 2009 11 november 2009 7 oktober 2009 9 oktober 2009 9 oktober 2009 28 augustus 2009 22 september 2009 25 september 2009 30 september 2009 30 september 2009 Thank you in advance Per. Jack. "Per Jessen" schreef in bericht ... Jack, You are close, but no need to select the shapes: DestSh.Shapes("resteert").Delete DestSh.Shapes("betaald").Delete DestSh.Shapes("legenda_1").Delete DestSh.Shapes("L").Delete Per "Jack Sons" skrev i meddelelsen ... Per, If you change the code to copy row 1 also and paste starting in row 1 I did this With TargetSh .Range("DM1:DM" & eindrij).AutoFilter field:=1, Criteria1:="<x" .Range("A1:C" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") .Range("F1:F" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N1") .Range("AA1:AA" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O1") ... .Range("DM1:DM" & eindrij).AutoFilter End With but then the text boxes come with the cells of row 1 of TargetSh. I got rid of them with DestSh.Shapes("resteert").Select Selection.Delete DestSh.Shapes("betaald").Select Selection.Delete DestSh.Shapes("legenda_1").Select Selection.Delete DestSh.Shapes("L").Select Selection.Delete which is rather clumsy, I'm afraid (better: I'm sure). What now? Jack. "Per Jessen" schreef in bericht ... Jack, I am glad you learned a bit from my code. If you change the code to copy row 1 also and paste starting in row 1, the textbox will not be copied, neither will the content of the textbox. You can place the content of the textbox in the underlying cell. To do that, enter design mode, and right click a textbox Properties Find LinkedCell property, and enter the cell address, eg. A1, then you just change the code to copy/paste starting at row 1 .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") Hopes this helps. ... Per "Jack Sons" skrev i meddelelsen ... Per, Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht ... Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh .Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" .Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") .Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") .Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") .Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") .Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") .Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") .Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") .Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") .Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") .Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen ... Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy columns A to C to sheet 2 colums A to C rows 2 and further, column D to sheet 2 colum N rows 2 and further, column AA to sheet 2 column O rows 2 and further, columns AK and AL to sheet 2 colums D and E rows 2 and further, column AM to sheet 2 column G rows 2 and further, column AN to sheet 2 column F rows 2 and further, column AO to sheet 2 column J rows 2 and further, column AP to sheet 2 column H rows 2 and further, column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands |
copying some rows and columns
Jack,
You can improve the previous code a bit further: With DestSh .Shapes("resteert").Delete .Shapes("betaald").Delete .Shapes("legenda_1").Delete .Shapes("L").Delete End With I do not hope you have any data in column L as it is used as helper column in the macro below. I think this is what you asked for: Sub Jack() Dim LastRow As Long Dim cell As Range Application.Screenupdating=False LastRow = Range("A" & Rows.Count).End(xlUp).Row Range("K2:K" & rows.Count).Clear Range("K2").Formula = "=Max(D2:J2)" Range("K2:K" & LastRow).FillDown For Each cell In Range("K2:K" & LastRow).Cells If cell.Value < Date Then cell.Font.Bold = True cell.Font.ColorIndex = 5 cell.Offset(0, 1) = 3 ElseIf cell.Value = cell.Offset(0, -1) Or _ cell.Value = cell.Offset(0, -2) Then With cell .Font.Bold = True .Font.ColorIndex = 3 .Offset(0, 1) = 1 End With Else cell.Offset(0, 1) = 2 End If Next Range("A2:L" & LastRow).Sort Key1:=Range("L2"), _ Order1:=xlAscending, Key2:=Range("K2"), _ Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, _ MatchCase:=False, Orientation:=xlTopToBottom Columns("L").Clear Application.Screenupdating=True End Sub -Per On 4 Okt., 00:47, "Jack Sons" wrote: Yes Per, I used that, thanks. Now I would like to use nice compact and fast executing code for the following complex conditions. Row 1 contains headers. Cells in colums D to J (from row 2 downwards, as far below as there are names in column A) contain dates or nothing. In each row I want in column K the "highest" (most future) date but * * in bold and red if it is a future date of colums I or J * * in regular and black if *is a future date of colums D to H * * in bold and blue if it is a date in the past and * * the rows with a bold and red date in column K sorted ascending to the dates in column K * * the rows with a ragular and black date in column K sorted ascending to the dates in column K * * the rows with a bold and blue date in column K sorted ascending to the dates in column K So column K will look like a red, blach and blue flag, like shown below (hope it will show after sending it over internet, colors are red for the first four dates, black for the following three and blue for the last five). 8 oktober 2009 14 oktober 2009 9 november 2009 11 november 2009 7 oktober 2009 9 oktober 2009 9 oktober 2009 28 augustus 2009 22 september 2009 25 september 2009 30 september 2009 30 september 2009 Thank you in advance Per. Jack. "Per Jessen" schreef in l... Jack, You are close, but no need to select the shapes: DestSh.Shapes("resteert").Delete DestSh.Shapes("betaald").Delete DestSh.Shapes("legenda_1").Delete DestSh.Shapes("L").Delete Per "Jack Sons" skrev i meddelelsen ... Per, If you change the code to copy row 1 also and paste starting in row 1 I did this With TargetSh * *.Range("DM1:DM" & eindrij).AutoFilter field:=1, Criteria1:="<x" * *.Range("A1:C" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") * *.Range("F1:F" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N1") * *.Range("AA1:AA" & eindrij).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O1") * * * *... * *.Range("DM1:DM" & eindrij).AutoFilter End With but then the text boxes come with the cells of row 1 of TargetSh. I got rid of them with * *DestSh.Shapes("resteert").Select * *Selection.Delete * *DestSh.Shapes("betaald").Select * *Selection.Delete * *DestSh.Shapes("legenda_1").Select * *Selection.Delete * *DestSh.Shapes("L").Select * *Selection.Delete which is rather clumsy, I'm afraid (better: I'm sure). What now? Jack. "Per Jessen" schreef in bericht ... Jack, I am glad you learned a bit from my code. If you change the code to copy row 1 also and paste starting in row 1, the textbox will not be copied, neither will the content of the textbox. You can place the content of the textbox in the underlying cell. To do that, enter design mode, and right click a textbox Properties Find LinkedCell property, and enter the cell address, eg. A1, then you just change the code to copy/paste starting at row 1 .Range("A1:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A1") Hopes this helps. ... Per "Jack Sons" skrev i meddelelsen ... Per, Thank you. So much of my own clumsy code I can now discard! I really learned a thing or two (or more)! What if I also want to bring the cells in row 1 of the columns mentioned to the destination sheet and I do not want the textboxes that exist in row 1 of the targetsheet to be copied to the destination sheet? Jack. "Per Jessen" schreef in bericht .. . Hi I think this is what you need: Sub aaa() Dim TargetSh As Worksheet Dim DestSh As Worksheet Dim LastRow As Long Application.ScreenUpdating = False Set TargetSh = Worksheets("Sheet1") Set DestSh = Worksheets("Sheet2") LastRow = 252 With TargetSh * *.Range("DM1:DM" & LastRow).AutoFilter field:=1, Criteria1:="<x" * *.Range("A2:C" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("A2") * *.Range("D2:D" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("N2") * *.Range("AA2:AA" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("O2") * *.Range("AK2:AL" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("D2") * *.Range("AM2:AM" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("G2") * *.Range("AN2:AN" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("F2") * *.Range("AO2:AO" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("J2") * *.Range("AP2:AP" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("H2") * *.Range("AR2:AR" & LastRow).SpecialCells(xlCellTypeVisible).Copy DestSh.Range("I2") * *.Range("DM1:DM" & LastRow).AutoFilter End With Application.ScreenUpdating = True End Sub Regards, Per "Jack Sons" skrev i meddelelsen . .. Hi all, Of sheet 1, rows 2 tot 252 and columns A to AR I want to copy * *columns A to C to sheet 2 colums A to C rows 2 and further, * *column D to sheet 2 colum N rows 2 and further, * *column AA to sheet 2 column O rows 2 and further, * *columns AK and AL to sheet 2 colums D and E rows 2 and further, * *column AM to sheet 2 column G rows 2 and further, * *column AN to sheet 2 column F rows 2 and further, * *column AO to sheet 2 column J rows 2 and further, * *column AP to sheet 2 column H rows 2 and further, * *column AR to sheet 2 column I rows 2 and further, and all that only for those rows where in column DM is not an "x". Formats, text colors and interior colors are also to be copied. Due to clumsy code (sorry for that) I can't change the order of the columns in sheet 1 without getting an awful lot of trouble. I'm looking for nice compact and fast executing code, your assistance will be appreciated. Jack Sons The Netherlands- Skjul tekst i anførselstegn - - Vis tekst i anførselstegn - |
| All times are GMT +1. The time now is 05:20 PM. |
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
ExcelBanter.com