Goedemiddag,
Als amateur heb ik het voor elkaar gekregen om lange kolommen te knippen en op één pagina te krijgen.
De code die ik gebruik is:
Dit werkt goed, maar graag had ik het kopieër en plakgedeelte anders gezien.
De lijst is namelijk niet altijd even lang.
Zelf ben ik al aan het zoeken geweest, ben iets tegengekomen voor twee kolommen, maar om dit om te zetten voor mijn 4 kolommen gaat mijn pet te boven.
Heel graag jullie hulp hiervoor.
Alvast bedankt:
RvD.
Onderstaande code heb ik hier gevonden, maar krijg het niet aan de praat voor 4 kolommen
Als amateur heb ik het voor elkaar gekregen om lange kolommen te knippen en op één pagina te krijgen.
De code die ik gebruik is:
Code:
Range("C4:F160").Select
Selection.Copy
Sheets("Blad2").Select
Range("A1").Select
ActiveSheet.Paste
'===================================================
Cells.Replace What:="amsterdam", Replacement:="ASD", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="apeldoorn", Replacement:="AP", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Den Bosch", Replacement:="HT", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Hengelo", Replacement:="HGL", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Range("M10").Select
Cells.Replace What:="Kolham", Replacement:="KHM", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Zwolle", Replacement:="ZL", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Nieuwegein", Replacement:="NWG", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="Waddinxveen", Replacement:="WVN", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
ActiveWindow.SmallScroll Down:=24
Columns("A:A").EntireColumn.AutoFit
Columns("B:B").EntireColumn.AutoFit
Columns("C:C").EntireColumn.AutoFit
Columns("D:D").EntireColumn.AutoFit
Range("A1").Select
Dim cCell As Range
Dim ws As Worksheet
Set ws = ActiveSheet
For Each cCell In ws.UsedRange
If cCell.Formula <> "" Then
cCell.Borders.LineStyle = xlContinuous
cCell.Borders.Weight = xlThin
cCell.Borders.ColorIndex = xlAutomatic
End If
Next
Range("A51:D100").Select
Selection.Cut
Range("F1").Select
ActiveSheet.Paste
Range("A101:D137").Select
Selection.Cut
Range("A51").Select
ActiveSheet.Paste
'==========================================================================
Columns("B:B").EntireColumn.AutoFit
Columns("G:G").EntireColumn.AutoFit
Columns("E:E").ColumnWidth = 1.86
Columns("B:B").Select
Range("B34").Activate
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2.57
Columns("H:H").Select
Range("H34").Activate
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Selection.ColumnWidth = 2.14
Columns("B:B").ColumnWidth = 2.43
Columns("C:C").ColumnWidth = 14
'======================================================================
For Each cell In Range("A1:G100")
If InStr(cell, "ASD") > 0 Then
'cell.Interior.Color = 16772300
With cell.Interior
.Pattern = xlPatternRectangularGradient
.Gradient.RectangleLeft = 0.5
.Gradient.RectangleRight = 0.5
.Gradient.RectangleTop = 0.5
.Gradient.RectangleBottom = 0.5
.Gradient.ColorStops.Clear
End With
With cell.Interior.Gradient.ColorStops.Add(0)
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.80001220740379
End With
With cell.Interior.Gradient.ColorStops.Add(1)
.ThemeColor = xlThemeColorAccent1
.TintAndShade = 0.400006103701895
End With
Else
End If
Next
For Each cell In Range("A1:G100")
If InStr(cell, "HT") > 0 Then
cell.Interior.Color = 16772300
Else
End If
Next
For Each cell In Range("A1:G100")
If InStr(cell, "KHM") > 0 Then
cell.Interior.Color = 16772300
Else
End If
Next
For Each cell In Range("A1:G100")
If InStr(cell, "WVN") > 0 Then
cell.Interior.Color = 16772300
Else
End If
Next
'==========================================================
ActiveSheet.PageSetup.PrintArea = "A1:A100" & ":K" & Cells(Rows.Count, "K").End(xlUp).Row
'ActiveSheet.PrintOut
ActiveSheet.PrintPreview
'ActiveSheet.PrintOut Copies:=1
'ActiveWindow.Close SaveChanges:=False
End SubDit werkt goed, maar graag had ik het kopieër en plakgedeelte anders gezien.
De lijst is namelijk niet altijd even lang.
Zelf ben ik al aan het zoeken geweest, ben iets tegengekomen voor twee kolommen, maar om dit om te zetten voor mijn 4 kolommen gaat mijn pet te boven.
Heel graag jullie hulp hiervoor.
Alvast bedankt:
RvD.
Onderstaande code heb ik hier gevonden, maar krijg het niet aan de praat voor 4 kolommen
Code:
Dim lrow As Long
With Sheets("Blad2")
lrow = .HPageBreaks.Item(1).Location.Row
.Range("A1:B1").Copy .Range("D1")
With .Cells(lrow, 1).Resize(Range(.Cells(lrow, 1), .Cells(lrow, 1).End(xlDown)).Rows.Count, 2)
.Copy Range("D2")
.ClearContents
End With
.Columns("D:E").AutoFit
.PrintPreview
.Cells(1, 4).CurrentRegion.Offset(1).Copy .Cells(lrow, 1)
.Columns("D:E").Clear
End With
Laatst bewerkt:
