I need to copy every row 12 times from sheet1 to sheet 2.
Right now I copy the first row 12 times but row 2 is only copied once. I have provided a sample of the sheet and my code. Hope you guys can help.
My data starts in row a13
As a bonus I need to transpone the values in columns E:P
The reason why I need to do this is because all values in E:P is the value for each month and the values in A:C is the attributes that is necessary to identify the values in month to a certain car with year, registrations number and service
Sub copyEachRow()
Dim i As Integer
For i = 1 To 12
Sheets("asheet1").Range("A13").CurrentRegion.Copy Sheets("sheet2").Cells(i + 13, "a")
Next i
End Sub
Copy Transpose
Option Explicit
Sub copyEachRow()
Const srcName As String = "Sheet1"
Const sFirst As String = "A13"
Const dstName As String = "Sheet2"
Const dFirst As String = "A13"
Dim wb As Workbook
Set wb = ThisWorkbook
' Source Range to Source Array.
Dim Source As Variant
Source = wb.Worksheets(srcName).Range(sFirst).CurrentRegion.Value
Dim rCount As Long
rCount = UBound(Source, 1)
Dim Dest As Variant
ReDim Dest(1 To rCount * 12, 1 To 4)
' Write headers
Dim j As Long
For j = 1 To 3
Dest(1, j) = Source(1, j)
Next j
Dest(1, 4) = "Value"
' Write body.
Dim i As Long
Dim k As Long
Dim n As Long
For i = 2 To UBound(Source, 1)
For n = 1 To 12
k = k + 1
For j = 1 To 3
Dest(k, j) = Source(i, j)
Next j
Dest(k, 4) = Source(i, 3 + n)
Next n
Next i
' Destination Array to Destination Range.
With wb.Worksheets(dstName).Range(dFirst).Resize(, 4)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(k).Value = Dest
End With
End Sub
Sub copyEachRow()
Range("A1:C32").Select
Selection.Copy
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
Dim I As Long
Dim xCount As Integer
xCount = 11
For I = Range("A" & Rows.CountLarge).End(xlUp).Row To 1 Step -1
Rows(I).Copy
Rows(I).Resize(xCount).Insert
Next
Application.CutCopyMode = False
End Sub
you can adapt this piece of code to your need:
Sub copyEachRow()
Dim cel As Range
With Sheet2
For Each cel In Sheet1.Range("A13", Sheet1.Cells(.Rows.Count, 1).End(xlUp))
cel.EntireRow.Copy .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(12)
Next
End With
End Sub
just place a header in Sheet2 column A cell after which you want to paste data from
Related
I have created a function that retrieves a Range based on column name. Here is my code:
Sub sep_Filter()
Dim zip_rng As String
With Sheet2
zip_rng = getColRangeFunction("postalcode")
If Len(Range(zip_rng)) > 5 Then
Range(zip_rng).Interior.Color = RGB(255, 0, 0)
Range(zip_rng).Select
Else
Range(zip_rng).Interior.Color = xlNone
End If
End With
End Sub
Sheet2 Input Column D
Sheet2 Output Column D
Sheet3 Output Column D
088762598
088762598
06610-5000
06610-5000
330161898
330161898
970152880
970152880
112202570
112202570
127420800
127420800
062262040
062262040
07631
07631
10029
10029
11803
11803
99336
99336
EDIT I misunderstood what you were asking, I updated my answer to be tied to your question.
Here's a basic approach that will do what you're asking. It skips row one.
Sub onlyfirst5()
Const pRange As String = "D1"
Dim ws As Worksheet
Set ws = ActiveSheet
Dim crng As Range, cValues()
Set crng = Intersect(ws.UsedRange.Offset(1, 0), ws.UsedRange, ws.Range("D:D"))
cValues = crng.Value
Dim i As Long, j As Long
For i = LBound(cValues) To UBound(cValues)
For j = LBound(cValues, 2) To UBound(cValues, 2)
cValues(i, j) = Left(cValues(i, j), 5)
Next j
Next i
'for same sheet different column
ws.Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different sheet
Sheets("Sheet2").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
'different file
Workbooks("Zip Code Question.xlsb").Sheets("Sheet3").Range("F2").Resize(UBound(cValues), UBound(cValues, 2)) = Application.Transpose(cValues)
End Sub
Copy Entire Rows If Criteria Met
Option Explicit
Sub Postal5()
' Define constants.
Const srcName As String = "Sheet2"
Const srcFirst As String = "D2"
Const dstName As String = "Sheet3"
Const dstFirst As String = "A2" ' do not change the 'A' (entire row).
Const pLen As Long = 5
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define Source Range.
Dim LastRow As Long
Dim srg As Range
With wb.Worksheets(srcName).Range(srcFirst)
LastRow = .Offset(.Worksheet.Rows.Count - .Row).End(xlUp).Row
Set srg = .Resize(LastRow - .Row + 1)
End With
' 'Combine' critical cells into a range.
Dim brg As Range ' Built Range
Dim cel As Range ' Current Cell Range
For Each cel In srg.Cells
If Len(cel.Value) > pLen Then
If brg Is Nothing Then
Set brg = cel
Else
Set brg = Union(brg, cel)
End If
End If
Next cel
If brg Is Nothing Then Exit Sub
Application.ScreenUpdating = False
' Copy and delete critical rows of Source Range.
With wb.Worksheets(dstName).Range(dstFirst)
.Resize(.Worksheet.Rows.Count - .Row + 1, _
.Worksheet.Columns.Count).Clear
Set brg = brg.EntireRow ' 'Convert' cells into rows.
brg.Copy .Offset ' Copy. 'Offset' because range is in 'With'.
brg.Delete ' Delete.
End With
Application.ScreenUpdating = False
End Sub
Text the next code, please. It uses arrays and it should be very fast for a big range:
Sub testSplitZiPCodeStrings()
Dim sh2 As Worksheet, sh3 As Worksheet, lastR As Long
Dim i As Long, arr, arrZip, arrNoZip, kZ As Long, kN As Long
Set sh2 = ActiveSheet ' Worksheets("Sheet2")
Set sh3 = sh2.Next ' Worksheets("Sheet3")
lastR = sh2.Range("D" & sh2.Rows.count).End(xlUp).row 'last row
arr = sh2.Range("D2:D" & lastR).Value 'put the range in an array
ReDim arrZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
ReDim arrNoZip(UBound(arr) - 1) 'redim the array to surely have place for all elements
For i = 1 To UBound(arr) ' iterate between the array elements
If Len(arr(i, 1)) = 5 Then
arrZip(kZ) = arr(i, 1): kZ = kZ + 1
Else
arrNoZip(kN) = arr(i, 1): kN = kN + 1
End If
Next i
ReDim Preserve arrZip(kZ - 1) 'keep only the array elements having values
ReDim Preserve arrZip(kN - 1) 'keep only the array elements having values
sh2.Range("D2:D" & lastR).Clear 'Clear the initial range
'Drop the Zip array content at once:
sh2.Range("D2").Resize(UBound(arrZip), 1).Value = Application.Transpose(arrZip)
'Drop the NoZip array content at once:
sh3.Range("D2").Resize(UBound(arrNoZip), 1).Value = Application.Transpose(arrNoZip)
End Sub
Here's 2 samples. The first one is more intuitive and uses ranges. The second one is less intuitive but faster by using arrays.
Simple but Slower:
'The easy way, but can be slow if you have lots of zip codes
Sub TrimRange()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = RangeInput.Cells(i, 1).Value
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
RangeInput.Cells(i, 1).Value = Left(fullzipcode, 5)
End If
RangeOutput.Cells(i, 1).Value = fullzipcode
Next
End If
End Sub
Faster but Less Intuitive
'The harder way, but faster
Sub TrimRange2()
Dim InputWorksheet As Worksheet, OutputWorksheet As Worksheet
Dim RangeInput As Range, RangeOutput As Range, Column As Range
Dim HeaderRow As Integer, ColumnNumber As Integer, LastRow As Integer, i As Integer
Dim InputValues() As Variant, OutputValues() As Variant
Dim OutputColumn As Range
Dim ColumnFound As Boolean
Dim fullzipcode As String
Set InputWorksheet = Worksheets("Sheet2")
Set OutputWorksheet = Worksheets("Sheet3")
HeaderRow = 1
'Get Input and Output Range
ColumnNumber = 0
ColumnFound = False
For Each Column In InputWorksheet.Columns
ColumnNumber = ColumnNumber + 1
If Column.Cells(HeaderRow, 1) = "postalcode" Then
LastRow = Column.End(xlDown).Row
'I assume the Output column will be in the same position as the input column
Set OutputColumn = OutputWorksheet.Columns(ColumnNumber)
'If OutputColumn is always in Column 'D' then replace previous line with:
'Set OutputColumn = OutputWorksheet.Columns(4)
Set RangeInput = InputWorksheet.Range(Column.Cells(HeaderRow + 1, 1), Column.Cells(LastRow, 1))
Set RangeOutput = OutputWorksheet.Range(OutputColumn.Cells(HeaderRow + 1, 1), OutputColumn.Cells(LastRow, 1))
ColumnFound = True
Exit For
End If
Next
If ColumnFound Then
'Initialize Interior color to nothing
'and remove values from output column
RangeInput.Interior.ColorIndex = 0
RangeOutput.ClearContents
'Initialize Arrays (much faster than working with ranges)
InputValues = RangeInput.Value2
OutputValues = RangeOutput.Value2
'Change values and formatting
For i = 1 To RangeInput.Rows.Count
fullzipcode = InputValues(i, 1)
If Len(fullzipcode) > 5 Then
RangeInput.Cells(i, 1).Interior.Color = RGB(255, 0, 0)
InputValues(i, 1) = Left(fullzipcode, 5)
End If
OutputValues(i, 1) = fullzipcode
Next
'Save arrays to ranges
RangeInput.Value2 = InputValues
RangeOutput.Value2 = OutputValues
End If
End Sub
The ultimate goal is to set the status of a particular row to "Yes" and have the data of that row that is highlighted RED automatically be entered into another sheet in order to be printed in a format required for a Zlabel printer.
If you can imagine this raw data on a larger scale and having to print 50+ rows daily. I do this manually now but really hoping to streamline this process
This is how I'm hoping the data will look on a separate sheet when the status is set to "Yes" regardless of how many rows there are I could print in bulk
Open to any other suggestions that may include VBA macros or any other recommended solutions.
Any advice or help is extremely appreciated!
Try,
Sub test()
Dim Ws As Worksheet, toWs As Worksheet
Dim vDB, vR()
Dim i As Long, n As Long, r As Long
Set Ws = Sheets(1) 'Data sheet
Set toWs = Sheets(2) 'Result sheet
vDB = Ws.Range("a1").CurrentRegion
r = UBound(vDB, 1)
For i = 1 To r
If vDB(i, 9) = "Yes" Then
n = n + 5
ReDim Preserve vR(1 To n)
vR(n - 4) = vDB(i, 1)
vR(n - 3) = vDB(i, 4)
vR(n - 2) = vDB(i, 5)
vR(n - 1) = vDB(i, 7)
End If
Next i
With toWs
.UsedRange = Empty
.Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End With
End Sub
If you have Excel O365, then you could also opt for a formula. If your data has to start in Sheet2!A1 onwards then in A1:
=IF(MOD(ROW(),5)>0,INDEX(INDEX(FILTER(Sheet1!A:H,Sheet1!I:I="Yes"),SEQUENCE(COUNTIF(Sheet1!I:I,"Yes")),{1;4;5;7}),ROUNDUP(ROW()/5,0),MOD(ROW(),5)),"")
Drag down.
Copy By Criteria
The following automatically clears the contents of the Target Worksheet
("Sheet2") and copies all data specified by Crit ("Yes") to
it ("Sheet2"), when any data in the Criteria Column ("I") of
the Source Worksheet ("Sheet1") is manually changed (i.e.
it could be written to run more efficiently).
If you don't want it to run automatically, then remove the code from
the Sheet Module and just run the first Sub (maybe using a
button) when needed (which was my first idea).
You can change tgtGap, the number of rows in between data blocks.
You can add or remove columns to the Cols array.
Standard Module e.g. Module1
Option Explicit
Public Const CriteriaColumn As Variant = "I" ' e.g. "A" or 1
Sub copyByCriteria()
' Source
Const srcName As String = "Sheet1"
Const FirstRow As Long = 2
Const Crit As String = "Yes"
Dim Cols As Variant: Cols = Array("A", "D", "E", "G") ' or 1, 4, 5, 7
' Target
Const tgtName As String = "Sheet2"
Const tgtFirstCell As String = "A1"
Const tgtGap As Long = 1
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Collect data from Source Worksheet.
Dim ws As Worksheet: Set ws = wb.Worksheets(srcName)
Dim Criteria As Variant
getColumn Criteria, ws, CriteriaColumn, FirstRow
If IsEmpty(Criteria) Then Exit Sub
Dim ubC As Long: ubC = UBound(Criteria)
Dim ubD As Long: ubD = UBound(Cols)
Dim Data As Variant: ReDim Data(ubD)
Dim j As Long
For j = 0 To ubD
Data(j) = ws.Cells(FirstRow, Cols(j)).Resize(ubC)
Next j
Dim critCount As Long
critCount = Application.WorksheetFunction _
.CountIf(ws.Columns(CriteriaColumn), Crit)
' Write data from Data Arrays to Target Array.
Dim Target As Variant, i As Long, k As Long
ReDim Target(1 To critCount * (ubD + 1 + tgtGap) - tgtGap, 1 To 1)
For i = 1 To ubC
If Criteria(i, 1) = Crit Then
For j = 0 To ubD
k = k + 1
Target(k, 1) = Data(j)(i, 1)
Next j
k = k + tgtGap
End If
Next i
' Write Target Array to Target Worksheet.
Set ws = wb.Worksheets(tgtName)
ws.Cells.ClearContents
ws.Range(tgtFirstCell).Resize(UBound(Target)).Value = Target
End Sub
Sub getColumn(ByRef Data As Variant, _
Sheet As Worksheet, _
Optional aColumn As Variant = 1, _
Optional FirstRow As Long = 1)
Dim rng As Range
Set rng = Sheet.Columns(aColumn).Find("*", , xlValues, , , xlPrevious)
If rng Is Nothing Then Exit Sub
If rng.Row < FirstRow Then Exit Sub
If rng.Row > FirstRow Then
Data = Sheet.Range(Sheet.Cells(FirstRow, aColumn), rng).Value
Else
ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rng.Value
End If
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Me.Columns(CriteriaColumn)) Is Nothing Then
copyByCriteria
End If
End Sub
I have a worksheet with columns A:M and rows 1 to 5000. I would like to copy rows to another worksheet when a number greater then 0 is added to column L and M. I also only require columns A:F and K:M on the new worksheet
you'll need to name the source and target worksheets, but below code should do the trick.
Sub SheetTransfer()
Dim i As Long
Dim j As Long
Dim t As Double
Dim LastRow As Long
Dim ws1 As String
Dim ws2 As String
'name source worksheet here
ws1 = "Sheet1"
'name target worksheet here
ws2 = "Sheet2"
'set the threshold value for a row to be copied over
t = 0
' set to column L
j = 12
For i = 1 To 5000
If Worksheets(ws1).Cells(i, j).Value > 0 Or Cells(i, j + 1).Value > t Then
'find last row of target worksheet
With Worksheets(ws2)
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'copy/paste columns A-F
Worksheets(ws1).Range(Cells(i, 1), Cells(i, 6)).Copy
Worksheets(ws2).Cells(LastRow + 1, 1).PasteSpecial xlPasteValues
'copy paste columns K-M
Worksheets(ws1).Range(Cells(i, 11), Cells(i, 13)).Copy
Worksheets(ws2).Cells(LastRow + 1, 11).PasteSpecial xlPasteValues
End If
Next i
End Sub
Copy Data to Other Worksheet
Adjust the values in the constants section to fit your needs.
The Code
Sub AM5000()
' Source
Const cVntSource As Variant = "Sheet1" ' Source Worksheet Name/Index
Const cStrRange1 As String = "A1:F5000" ' Source 1 Range Address
Const cStrRange2 As String = "K1:M5000" ' Source 2 Range Address
Const cIntCol1 As Integer = 2 ' Source Range Criteria Column 1
Const cIntCol2 As Integer = 3 ' Source Range Criteria Column 2
' Target
Const cVntTarget As Variant = "Sheet2" ' Target Worksheet Name/Index
Const cStrTarget As String = "A1" ' Target First Cell Address
Dim vnt1 As Variant ' Source 1 Array
Dim vnt2 As Variant ' Source 2 Array
Dim vntTarget As Variant ' Target Array
Dim i As Integer ' Source Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Integer ' Target Array Row Counter
' Paste Source Ranges into Source Arrays.
With Worksheets(cVntSource)
vnt1 = .Range(cStrRange1)
vnt2 = .Range(cStrRange2)
End With
' Count the number of rows for Target Array.
For i = 1 To UBound(vnt2)
If vnt2(i, cIntCol1) > 0 And vnt2(i, cIntCol2) > 0 Then
k = k + 1
End If
Next
' Write Source Arrays to Target Array.
ReDim vntTarget(1 To k, 1 To UBound(vnt1, 2) + UBound(vnt2, 2))
k = 0
For i = 1 To UBound(vnt2)
If vnt2(i, cIntCol1) > 0 And vnt2(i, cIntCol2) > 0 Then
k = k + 1
For j = 1 To UBound(vnt1, 2)
vntTarget(k, j) = vnt1(i, j)
Next
For j = 1 To UBound(vnt2, 2)
vntTarget(k, j + UBound(vnt1, 2)) = vnt2(i, j)
Next
End If
Next
' Paste Target Array into Target Range.
With Worksheets(cVntTarget).Range(cStrTarget)
'.Parent.Cells.ClearContents
.Resize(UBound(vntTarget), UBound(vntTarget, 2)) = vntTarget
End With
End Sub
In the picture of the sheet I get my data from "Ark2" and the sheet I get the data to "Ark1". In Ark1 I want want to give an ID for the data. I show an example in yellow, grey, green and blue colours. I want the text ID to stand as it does in the example row "K".
the code is added at the end..
Sub MyProcedure()
a = Worksheets("ark1").Cells(Rows.Count, 1).End(xlUp).Row
MsgBox (a)
End Sub
Private Sub CommandButton1_Click()
Dim nøgletal As String, år As Integer
Worksheets("Ark2").Select
nøgletal = Range("B2")
år = Range("C2")
Worksheets("Ark1").Select
Worksheets("Ark1").Range("A4").Select
ThisWorkbook.Worksheets("Ark1").Range("A1:A100").Value = ThisWorkbook.Worksheets("Ark2").Range("A12:A100").Value
ThisWorkbook.Worksheets("Ark1").Range("B1:B100").Value = ThisWorkbook.Worksheets("Ark2").Range("B12:B100").Value
ThisWorkbook.Worksheets("Ark1").Range("C1:C100").Value = ThisWorkbook.Worksheets("Ark2").Range("C12:C100").Value
ThisWorkbook.Worksheets("Ark1").Range("E1:E100").Value = ThisWorkbook.Worksheets("Ark2").Range("E12:E100").Value
ThisWorkbook.Worksheets("Ark1").Range("G1:G100").Value = ThisWorkbook.Worksheets("Ark2").Range("M12:M100").Value
ThisWorkbook.Worksheets("Ark1").Range("F1:F100").Value = ThisWorkbook.Worksheets("Ark2").Range("N12:N100").Value
ThisWorkbook.Worksheets("Ark1").Range("H1:H100").Value = ThisWorkbook.Worksheets("Ark2").Range("O12:O100").Value
If Worksheets("Ark1").Range("A4").Offset(1, 0) <> "" Then
Worksheets("Ark1").Range("A4").End(xlDown).Select
End If
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = nøgletal
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = år
Worksheets("Ark2").Select
Worksheets("Ark2").Range("B2", "B16").Select
End Sub
Sub x()
Dim lngDataColumns As Long
Dim lngDataRows As Long
lngDataColumns = 3
lngDataRows = 15
For t = 1 To lngDataRows
Range("l2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Value)
Range("M2").Offset(((t - 1) * lngDataColumns) - 1, 0).Resize(lngDataColumns, 1).Value = _
Application.Transpose(Range("f1:h1").Offset(t).Value)
Next t
End Sub
A Special Transpose Vol. 2
Adjust the values in the constants section to fit your needs.
The first data row in Range1 (A2:C2) has to have values.
The Code
Sub TransposeAH()
Const cSheet1 As Variant = "Ark1" ' Sheet1 Name/Index
Const cSheet2 As Variant = "Ark1" ' Sheet2 Name/Index
Const cFirst As Integer = 2 ' First Row Number
Const cCol1First As Variant = "A" ' Range1 First Column Letter/Number
Const cCol1Last As Variant = "C" ' Range1 Last Column Letter/Number
Const cCol2First As Variant = "F" ' Range2 First Column Letter/Number
Const cCol2Last As Variant = "H" ' Range2 Last Column Letter/Number
Const cColumns As Integer = 2 ' Number of New Columns
Const cFirstCell As String = "L1" ' Target Range First Cell Address
Dim vntH As Variant ' Range2 Headers
Dim vnt2 As Variant ' Range2 Array
Dim vnt3 As Variant ' Range1 Temp Array (if value is "")
Dim vnt1 As Variant ' Range1 Array
Dim vntT As Variant ' Target Array
Dim LastUR As Long ' Last Used Row
Dim i As Long ' Arrays Row Counter
Dim j As Integer ' Arrays Column Counter
Dim k As Long ' Target Array Rows Counter
Dim m As Integer ' Range1 Temp Array Column Counter
' From Sheet1 to Arrays.
With Worksheets(cSheet1)
' Calculate Last Used Row.
With .Range(.Cells(cFirst, cCol1First), .Cells(.Rows.Count, cCol2Last))
If .Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
Is Nothing Then Exit Sub
LastUR = .Find("*", , , , , 2).Row
End With
' Paste ranges into arrays.
vnt1 = .Range(.Cells(cFirst, cCol1First), .Cells(LastUR, cCol1Last))
vnt2 = .Range(.Cells(cFirst, cCol2First), .Cells(LastUR, cCol2Last))
vntH = .Range(.Cells(cFirst - 1, cCol2First), _
.Cells(cFirst - 1, cCol2Last))
End With
' Resize Target Array.
ReDim vntT(1 To UBound(vnt2) * UBound(vnt2, 2), _
1 To cColumns + UBound(vnt1, 2))
' Write Range2 Array to Target Array.
For i = 1 To UBound(vnt2)
For j = 1 To UBound(vnt2, 2)
k = k + 1
vntT(k, 1) = vntH(1, j)
vntT(k, 2) = vnt2(i, j)
Next
Next
' Resize Range1 Temp Array (if value is "")
ReDim vnt3(1 To 1, 1 To UBound(vnt1, 2))
' Copy first line of Range1 Array to Range1 Temp Array.
For m = 1 To UBound(vnt3, 2)
vnt3(1, m) = vnt1(1, m)
Next
' Write Range1 Array to Target Array.
k = 0
For i = 1 To UBound(vnt1)
For j = 1 To UBound(vnt1, 2)
k = k + 1
For m = 1 To UBound(vnt2, 2)
If vnt1(i, m) <> "" Then
If vnt1(i, m) <> vnt3(1, m) Then
vnt3(1, m) = vnt1(i, m)
End If
End If
vntT(k, m + cColumns) = vnt3(1, m)
Next
Next
Next
' Paste Target Array into Target Range resized
' from Target Range First Cell Address.
With Worksheets(cSheet2).Range(cFirstCell)
.Resize(UBound(vntT), UBound(vntT, 2)) = vntT
End With
End Sub
I know this question has been asked already but I can't seem to make what I find work for me.
I just want to take all the data starting in column A and going to column J from row 2 to whatever the end of the data might be and reverse the order(inverse the data)
I stumbled upon the the code below but it freezes and I don't want to have to make a selection.
Private Sub CommandButton2_Click()
Dim vTop As Variant
Dim vEnd As Variant
Dim iStart As Integer
Dim iEnd As Integer
Application.ScreenUpdating = False
iStart = 1
iEnd = Selection.Columns.Count
Do While iStart < iEnd
vTop = Selection.Columns(iStart)
vEnd = Selection.Columns(iEnd)
Selection.Columns(iEnd) = vTop
Selection.Columns(iStart) = vEnd
iStart = iStart + 1
iEnd = iEnd - 1
Loop
Application.ScreenUpdating = True
End Sub
To be clear, I want to make the last row the first row, and the last row the first row. This is a continuous block of data.
Cheers
before
after
Another version of the code - see if this works.
Private Sub CommandButton2_Click()
Dim v(), i As Long, j As Long, r As Range
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Range("A1").CurrentRegion
Set r = .Offset(1).Resize(.Rows.Count - 1)
End With
ReDim v(1 To r.Rows.Count, 1 To r.Columns.Count)
For i = 1 To r.Rows.Count
For j = 1 To r.Columns.Count
v(i, j) = r(r.Rows.Count - i + 1, j)
Next j
Next i
r = v
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
The code below copies the data in each column to column number 20 - current column index, and at the end of the For loop it deletes the original data that lies in Columns A:J.
Option Explicit
Private Sub CommandButton2_Click()
Dim LastRow As Long
Dim Col As Long
Dim ColStart As Long, ColEnd As Long
Application.ScreenUpdating = False
' Column A
ColStart = 1
' Column J
ColEnd = 10 ' Selection.Columns.Count
' modify "Sheet1" to your sheet's name
With Sheets("Sheet1")
For Col = ColStart To ColEnd
' find last row with data for current column
LastRow = .Cells(.Rows.Count, Col).End(xlUp).Row
' copy in reverse order to column 20 to 11
' copy current column to column 20-current column index
.Range(Cells(2, Col), Cells(LastRow, Col)).Copy .Range(Cells(2, 20 - Col), Cells(LastRow, 20 - Col))
Next Col
End With
' delete original data in column A:J
With Sheets("Sheet1")
.Columns("A:J").EntireColumn.Delete
End With
Application.ScreenUpdating = True
End Sub
Like so? This assumes a continuous block of data from A2 (the currentregion) so will extend beyond J if there is more data, but could be restricted
Private Sub CommandButton2_Click()
Dim v, i As Long, r As Range
Application.ScreenUpdating = False
With Range("A1").CurrentRegion
Set r = .Offset(1).Resize(.Rows.Count - 1)
End With
v = r
For i = 1 To r.Rows.Count
r.Rows(i).Cells = Application.Index(v, r.Rows.Count - i + 1, 0)
Next i
Application.ScreenUpdating = True
End Sub