I have the following bit in a macro in my workbook. It selects the last n=10 rows to set as the data source.
.lstDbase.RowSource = "Stencils!A" & iRow - 10 & ":R" & iRow
Am I able to reverse this selection without actually saving the reversed data?
Get Range Rows Reverse
Option Explicit
Sub PopulateRangeRowsReverse() ' ???
Const fRow As Long = 2 ' ???
Const rMaxOffset As Long = 10
'Const iRow As Long = 11 ' ???
'With ???
Dim lrCount As Long: lrCount = iRow - fRow + 1
If lrCount < 1 Then Exit Sub ' no data
If lrCount > rMaxOffset Then lrCount = rMaxOffset
Dim rg As Range
Set rg = ThisWorkbook.Worksheets("Stencils") _
.Rows(iRow - lrCount + 1).Columns("A:R").Resize(lrCount)
Dim Data As Variant: Data = GetRangeRowsReverse(rg)
With .lstDbase
.Clear
.ColumnCount = rg.Columns.Count
.List = Data
End With
'End With
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the reversed rows of a range in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRangeRowsReverse( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRangeRowsReverse"
On Error GoTo ClearError
Dim sData As Variant
Dim rCount As Long
Dim cCount As Long
With rg
rCount = .Rows.Count
cCount = .Columns.Count
If rCount + cCount = 2 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = .Value
Else
sData = .Value
End If
End With
Dim dData As Variant: ReDim dData(1 To rCount, 1 To cCount)
Dim r As Long
Dim c As Long
For r = 1 To rCount
For c = 1 To cCount
dData(r, c) = sData(rCount, c)
Next c
rCount = rCount - 1
Next r
GetRangeRowsReverse = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
Related
I am currently working on a code for data validation. The excel colors the cells that are entered incorrectly (orange for wrong range, red for wrong datatype). I first used message boxes to show the wrong values but when I have a lot of entries it is annoying to all click all of them away. My new idea would be to save all the errors as Strings in a dynamic array, which i can print out in a loop at the end and show all at once. Unfortunately, I am a beginner in vba and dont know if this idea is even possible to execute. How could I implement this idea?
Sub CheckColumns()
Dim rng As Range
Dim lCol As Long, lRow As Long
Dim DblLengthMin As Double
'Dim dynamicArray() As String
'Dim f As Integer
DblLengthMax = 20000
DblLengthMin = 5
lCol = Range("C2").End(xlToRight).Column
lRow = Range("C2").End(xlDown).Row
For Each rng In Range("C2", Cells(lRow, lCol))
If IsNumeric(rng) = False Then
rng.Interior.ColorIndex = 3
'Array Entry: "A number has to be entered " & "Row " & rng.Row & " Column " &
'rng.Column
End If
If IsNumeric(rng) And rng.Value > DblLengthMax Or rng.Value < DblLengthMin Then
rng.Interior.ColorIndex = 46
'ArrayEntry "Value in " & "Row " & rng.Row & " Column " & rng.Column & " is out of
'range. Check for unit (mm)"
End If
Next rng
' Print out an extra window that shows the number of mistakes made and a list of them
and their place in their worksheet
End Sub
Data example
Create a Report For Cells Not Matching Criteria
Option Explicit
Sub CheckColumns()
' Define constants.
Const sName As String = "Sheet1"
Const sfCol As Long = 3
Dim dHeaders() As Variant: dHeaders = VBA.Array( _
"Id", "Mistake", "Value", "Row", "Column", "Action Needed")
Const gteMin As Double = 2
Const lteMax As Double = 20000
Const rColor As Long = 26367 ' a kind of orange
Const cColor As Long = 255 ' red
' Write the source data to a 2D one-based array ('sData').
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
Dim sws As Worksheet: Set sws = swb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim srOffset As Long: srOffset = 1
Dim srCount As Long: srCount = srg.Rows.Count - srOffset
Dim scOffset As Long: scOffset = sfCol - 1
Dim scCount As Long: scCount = srg.Columns.Count - scOffset
Dim sdrg As Range
Set sdrg = srg.Resize(srCount, scCount).Offset(1, sfCol - 1)
Dim sData() As Variant: sData = sdrg.Value
' Write the report data to 1D one-based arrays ('dDataRow')
' of a collection ('coll') and combine the cells containinig mistakes
' into ranges ('rrg','nrg').
Dim dcCount As Long: dcCount = UBound(dHeaders) + 1
Dim dDataRow() As Variant: ReDim dDataRow(1 To dcCount)
Dim coll As Collection: Set coll = New Collection
Dim rrg As Range ' not in range
Dim nrg As Range ' not a number
Dim sItem As Variant
Dim sRow As Long
Dim sCol As Long
Dim sr As Long
Dim sc As Long
Dim dr As Long
Dim IsNumber As Boolean
Dim InRange As Boolean
For sr = 1 To srCount
For sc = 1 To scCount
sItem = sData(sr, sc)
If VarType(sItem) = vbDouble Then
IsNumber = True
If sItem >= gteMin Then
If sItem <= lteMax Then
InRange = True
End If
End If
End If
If InRange Then
InRange = False
IsNumber = False
Else
dr = dr + 1
dDataRow(1) = dr
dDataRow(3) = sItem
sRow = sr + srOffset
dDataRow(4) = sRow
sCol = sc + scOffset
dDataRow(5) = sCol
If IsNumber Then
dDataRow(2) = "Not in range"
dDataRow(6) = "Check for unit (mm)"
Set rrg = RefCombinedRange(rrg, sws.Cells(sRow, sCol))
IsNumber = False
Else
dDataRow(2) = "Not a number"
dDataRow(6) = "Enter a number"
Set nrg = RefCombinedRange(nrg, sws.Cells(sRow, sCol))
End If
coll.Add dDataRow
End If
Next sc
Next sr
If coll.Count = 0 Then
MsgBox "No mistakes found.", vbExclamation
Exit Sub
End If
Application.ScreenUpdating = False
' Highlight cells.
srg.Interior.Color = xlNone
If Not rrg Is Nothing Then rrg.Interior.Color = rColor ' not in range
If Not nrg Is Nothing Then nrg.Interior.Color = cColor ' not a number
' Write the report data from the arrays in the collection
' to a 2D one-based array, the destination array ('dData').
Dim drCount As Long: drCount = dr + 1 ' include headers
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim dc As Long
' Write headers.
For dc = 1 To dcCount
dData(1, dc) = dHeaders(dc - 1)
Next dc
' Write data
dr = 1 ' skip headers
For Each sItem In coll
dr = dr + 1
For dc = 1 To dcCount
dData(dr, dc) = sItem(dc)
Next dc
Next sItem
' Write the data from the destination array to a new single-worksheet
' workbook, the destination workbook ('dwb').
Dim dwb As Workbook: Set dwb = Workbooks.Add(xlWBATWorksheet)
With dwb.Worksheets(1).Range("A1").Resize(, dcCount)
.Resize(drCount).Value = dData
.Font.Bold = True
.EntireColumn.AutoFit
End With
dwb.Saved = True ' just for easy closing
Application.ScreenUpdating = True
' Inform.
MsgBox "Columns checked.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function
I might recommend you to save all cells addresses with errors in one string variable with separator, and what is wrong in the other string variable. For example:
Dim strErrorAdress as String
Dim strError as String
For Each rng In Range("C2", Cells(lRow, lCol))
If IsNumeric(rng) = False Then
rng.Interior.ColorIndex = 3
If strErrorAdress = "" Then
strErrorAdress = rng.address & "/"
strError = "A number has to be entered" & "/"
Else
strErrorAdress =strErrorAdress & "/" & rng.address & "/"
strError = strError & "/" & "A number has to be entered" & "/"
End if
End If
If IsNumeric(rng) And rng.Value > DblLengthMax Or rng.Value < DblLengthMin Then
rng.Interior.ColorIndex = 46
If strErrorAdress = "" Then
strErrorAdress = rng.address & "/"
strError = "A number has to be entered" & "/"
Else
strErrorAdress =strErrorAdress & "/" & rng.address & "/"
strError = strError & "/" & "range. Check for unit (mm)" & "/"
End if
End If
Next rng
'Afterr all code delete last "/" in strings with
strErrorAdress = Left(strErrorAdress , Len(strErrorAdress ) - 1)
strError = Left(strError , Len(strError ) - 1)
'Then make arrays with split function
Dim arrSplitstrError() As String
Dim arrSplitstrErrorAdress() As String
arrSplitstrError = Split(strError , "/")
arrSplitstrErrorAdress = Split(strErrorAdress , "/")
'Now print errors like
dim counter as long
For counter = 0 to UBound(arrSplitstrError)
debug.print arrSplitstrErrorAdress(counter) & " - " & arrSplitstrError(counter) & vbNewLine
next counter
I'm not an expert, maybe there is a mistake in the code but the idea should be understood.
I have an Excel sheet with 4 pages that takes input budgetary adjustment data and reformats into two different formats for entry into different budget softwares.
On the sheets first page, the upload page (feed data), data is given in rows of budget adjustments. These adjustments always come in even numbers of rows because for every account that has money adjusted out of it, another account has that money adjusted into it. In each row there are a number of non-unique qualitative columns that describe the adjustment and then 12 month columns that record the monetary aspects of the adjustment. Some rows have only one month of the 12 filled and can be left alone. Other adjustments occur over several months and thus have several of the months columns filled.
For input into the two budget softwares, these rows that have multiple month columns filled with data need to be expanded into multiple new rows with only one of the 12 columns filled. For clarity, here's what the transformation should look like:
Input:
Output:
How can you do this with input data where some rows don't need to be transformed, some include 2 months of transactions, and some could include up to 12?
Option Explicit
Sub Only_one_data_value_per_row()
Dim myR As Range
Dim rowCt As Integer
Dim actRange As Range
Dim dataCt As Integer
Dim iCt As Integer
Dim myCell As Range
Set actRange = Range("A1").CurrentRegion
For rowCt = actRange.Rows.Count To 2 Step -1
With ActiveSheet.Rows(rowCt)
dataCt = Application.WorksheetFunction.Count(.Range("E1:P1"))
'Debug.Print .Range("E1:P1").Address, dataCt)
For iCt = 1 To dataCt - 1
Rows(rowCt + 1).EntireRow.Insert
Rows(rowCt).Range("A1:D1").Copy Rows(rowCt + 1).Range("A1")
Next iCt
iCt = 0
For Each myCell In Rows(rowCt).Range("E1:P1")
'Debug.Print rowCt; ":"; (nonEmptyCell)
If myCell.Value <> "" Then
Debug.Print myCell.Value
If Val(myCell.Value) = 0 Then
MsgBox "The value of the cell " & myCell.Address & _
" is 0! The cell will be deleted!"
myCell.Value = ""
Else
If iCt > 0 Then
myCell.Offset(iCt, 0).Value = myCell.Value
myCell.Value = ""
End If
iCt = iCt + 1
End If
End If
Next myCell
End With
Next rowCt
End Sub
Input:
Output:
Transform Data: One Value Per Row
Adjust the values in the constants section.
Option Explicit
Sub TransformOneValuePerRow()
' Source
Const sName As String = "Sheet1"
Const sFirstCellAddress As String = "C4"
' Destination
Const dName As String = "Sheet2"
Const dFirstCellAddress As String = "A1"
' Both
Const FixedColumnsCount As Long = 4
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the current region starting with the first cell.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sFirstCell As Range: Set sFirstCell = sws.Range(sFirstCellAddress)
Dim srg As Range
With sFirstCell.CurrentRegion
Set srg = sFirstCell.Resize(.Row + .Rows.Count - sFirstCell.Row, _
.Column + .Columns.Count - sFirstCell.Column)
End With
' Using 'GetTransformOneValuePerRow', return the transformed data
' in a 2D one-based array.
Dim Data As Variant
Data = GetTransformOneValuePerRow(srg, FixedColumnsCount)
If IsEmpty(Data) Then
MsgBox "An error occurred.", vbCritical
Exit Sub
End If
' Write to the destination range and clear below.
Dim rCount As Long: rCount = UBound(Data, 1)
With wb.Worksheets(dName).Range(dFirstCellAddress).Resize(, UBound(Data, 2))
.Resize(rCount).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
End With
MsgBox "Data transformed.", vbInformation
End Sub
Function GetTransformOneValuePerRow( _
ByVal SourceRange As Range, _
Optional ByVal FixedColumnsCount As Long = 1, _
Optional ByVal IncludeBlanks As Boolean = False) _
As Variant
Const ProcName As String = "GetTransformOneValuePerRow"
On Error GoTo ClearError
Dim sData As Variant ' Source Array
Dim srCount As Long ' Source Rows Count
Dim cCount As Long ' Source/Destination Columns Count
Dim drCount As Long ' Destination Rows Count
With SourceRange
srCount = .Rows.Count
cCount = .Columns.Count
With .Resize(srCount - 1, cCount - FixedColumnsCount) _
.Offset(1, FixedColumnsCount - 1) ' Values Range
drCount = .Rows.Count * .Columns.Count + 1
If Not IncludeBlanks Then _
drCount = drCount - Application.CountBlank(.Cells)
End With
sData = .Value
End With
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount) ' Dest. Array
Dim fvCol As Long: fvCol = FixedColumnsCount + 1 ' First Value Column
Dim dr As Long: dr = 1 ' Destination Row
Dim sr As Long ' Source Row
Dim fc As Long ' Fixed Column
Dim vc As Long ' Value Column
' Write headers.
For fc = 1 To cCount
dData(dr, fc) = sData(1, fc)
Next fc
' Write rest.
If IncludeBlanks Then ' all
For sr = 2 To srCount
For vc = fvCol To cCount
dr = dr + 1
dData(dr, vc) = sData(sr, vc)
For fc = 1 To FixedColumnsCount
dData(dr, fc) = sData(sr, fc)
Next fc
Next vc
Next sr
Else ' non-blank
For sr = 2 To srCount
For vc = fvCol To cCount
If Len(CStr(sData(sr, vc))) > 0 Then
dr = dr + 1
dData(dr, vc) = sData(sr, vc)
For fc = 1 To FixedColumnsCount
dData(dr, fc) = sData(sr, fc)
Next fc
End If
Next vc
Next sr
End If
GetTransformOneValuePerRow = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
I am attempting to combine four separate list of name into a single list without showing any duplicates. The code below uses the advanced filters to first filter for unique names from each of the four list and then combine them into a single name list. It then again uses advanced filters on the newly created consolidated name list to double check for duplicates and then writes the final list of unique names.
My issue is that the final name list is showing a single duplicate name that appears at both the beginning and at the end list.
Option Explicit
Sub CreateUniqueList()
Dim lastrow As Long
ActiveSheet.Range("d:d").Clear
ActiveSheet.Range("x:x").Clear
ActiveSheet.Range("g13:g36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("D2"), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("i13:i36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("k13:k36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row + 1
ActiveSheet.Range("m13:m36").AdvancedFilter xlFilterCopy, , ActiveSheet.Range("d" & lastrow), True
lastrow = Cells(Rows.Count, "d").End(xlUp).Row
ActiveSheet.Range("d2:d" & lastrow).AdvancedFilter xlFilterCopy, , ActiveSheet.Range("x2"), True
ActiveSheet.Range("d:d").Clear
End Sub
I'm sure it is a simple mistake but for the life of me I can't figure it out.
Copy Unique Values From Columns
AdvancedFilter will copy the headers, so if the first row is 1, and 1 is found somewhere below, it will remain a duplicate. An idea would be to copy the range from column D to X right before your last AdvancedFilter action and apply a RemoveDuplicates instead.
But I've opted for a faster solution using data structures i.e. writing the whole source range to an array, writing the unique values from the designated columns of the source range to a dictionary, writing the values from the dictionary to another array, and finally, writing the values from the array to the destination range. Also, there is no need for a helper column.
Option Explicit
Sub CreateUniqueList()
' Source
Const sName As String = "Sheet1"
Const srgAddress As String = "G13:M36"
Dim sCols As Variant: sCols = Array(1, 3, 5, 7)
' Destination
Const dName As String = "Sheet1"
Const dfCellAddress As String = "X2"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Return the values from the source range ('srg')
' in the 2D one-based source array ('sData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range(srgAddress)
Dim sData As Variant: sData = srg.Value
' Return the unique values from the designated columns ('sCols')
' of the source array in a dictionary ('dict')
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim c As Long
For c = LBound(sCols) To UBound(sCols)
DictAddColumn dict, sData, sCols(c)
Next c
Erase sData
' Return the values from the dictionary
' in the 2D one-based one-column destination array ('dData').
Dim dData As Variant: dData = GetColumnDictKeys(dict)
Set dict = Nothing
Dim drCount As Long: drCount = UBound(dData, 1)
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
With dws.Range(dfCellAddress)
' Write the result.
.Resize(drCount).Value = dData
' Clear below.
.Resize(dws.Rows.Count - .Row - drCount + 1) _
.Offset(drCount).ClearContents
End With
MsgBox "Unique list created.", vbInformation
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Adds the unique values from a column ('sColumnIndex')
' of a 2D array ('sData') to an existing dictionary ('dDict').
' Remarks: Error values and blanks are excluded.
' Remarks: 'ByRef' indicates that the dictionary in the calling procedure
' will be modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub DictAddColumn( _
ByRef dDict As Object, _
ByVal sData As Variant, _
Optional ByVal sColumnIndex As Variant, _
Optional ByVal DoCount As Boolean = False)
Const ProcName As String = "DictAddColumn"
On Error GoTo ClearError
Dim sKey As Variant
Dim sr As Long
For sr = LBound(sData, 1) To UBound(sData, 1)
sKey = sData(sr, sColumnIndex)
If Not IsError(sKey) Then
If Len(CStr(sKey)) > 0 Then
If DoCount Then
dDict(sKey) = dDict(sKey) + 1
Else
dDict(sKey) = Empty
End If
End If
End If
Next sr
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the keys from a dictionary ('sDict')
' in a 2D one-based one-column array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetColumnDictKeys( _
ByVal sDict As Object) _
As Variant
Const ProcName As String = "GetColumnDictKeys"
On Error GoTo ClearError
Dim dData As Variant: ReDim dData(1 To sDict.Count, 1 To 1)
Dim sKey As Variant
Dim dr As Long
For Each sKey In sDict.Keys
dr = dr + 1
dData(dr, 1) = sKey
Next sKey
GetColumnDictKeys = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
EDIT
This solution copies the complete ranges' values and applies RemoveDuplicates.
Sub CreateUniqueListCopyByAssignment()
' without helper column
Const cCount As Long = 4
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim srg As Range: Set srg = ws.Range("G13:G36")
Dim rCount As Long: rCount = srg.Rows.Count
Dim drg As Range: Set drg = ws.Range("X2").Resize(rCount)
Application.ScreenUpdating = False
ws.Range("X2:X" & ws.Rows.Count).Clear
Dim c As Long
For c = 0 To cCount - 1
drg.Offset(c * rCount).Value = srg.Offset(, c * 2).Value
Next c
drg.Resize(rCount * cCount).RemoveDuplicates 1, xlNo
Application.ScreenUpdating = True
End Sub
This solution is similar to yours, but it applies RemoveDuplicates near the end, mentioned at the top of this post. I think these ranges are too small to harvest the power of AdvancedFilter.
Sub CreateUniqueListQuickFix()
' with helper column
Application.ScreenUpdating = False
With ActiveSheet
Dim rCount As Long: rCount = .Rows.Count
Dim lr As Long
.Range("X2:X" & rCount).Clear
.Range("g13:g36").AdvancedFilter xlFilterCopy, , .Range("D2"), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("i13:i36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("k13:k36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row + 1
.Range("m13:m36").AdvancedFilter xlFilterCopy, , .Range("D" & lr), True
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).RemoveDuplicates 1, xlNo
lr = Cells(rCount, "D").End(xlUp).Row
.Range("D2:D" & lr).Copy .Range("X2")
.Range("D2:D" & lr).Clear
End With
Application.ScreenUpdating = True
End Sub
I don't know if it's possible to do it,
I need to copy data from sheet 2 from column B with a variable range,
selecting 8 lines at a time from sheet 2,
pasting with transposition in sheet 1 starting from row 9 onwards? thank you
Sub copy()
Sheets(2).Range("B1:B8").Copy
With Sheets(1).Range("B9:I9")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B9:B16").Copy
With Sheets(1).Range("B10:I10")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B17:B24").Copy
With Sheets(1).Range("B11:I11")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Sheets(2).Range("B25:B32").Copy
With Sheets(1).Range("B12:I12")
.PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
Application.CutCopyMode = True
End Sub ```
The code assumes that the range we want to copy and paste is always the same and always 8 rows.
I assume the original data looks like this:
Then we can copy and transpose the range to this:
by using this code:
Sub Copy_paste_transpose()
Dim lrow_copy As Long
Dim i As Long, j As Long
Dim rows_to_copy As Long
lrow_copy = Sheets(2).Cells(Rows.Count, "B").End(xlUp).Row 'Find last row in Sheet2
i = 9 'Start pasting at row 9
rows_to_copy = 7 'always "remove" one row.
For j = 1 To lrow_copy Step 8 'Loop through range and "jump" 8 rows at each looping.
Sheets(2).Range(Sheets(2).Cells(j, "B"), Sheets(2).Cells(j + rows_to_copy, "B")).Copy 'Copy range
Sheets(1).Range(Sheets(1).Cells(i, 2), Sheets(1).Cells(i, 2 + rows_to_copy)).PasteSpecial Paste:=xlPasteValues, Transpose:=True 'Paste range and transpose the copied range
i = i + 1 'add one row after each paste
Next j
Application.CutCopyMode = False 'Deselect last copy selection
End Sub
Try this code:
Sub copy()
Const PERIOD = 8, PASTE_FROM_ROW = 9
Dim last_row As Long, i As Long
last_row = Sheets(2).Cells(Rows.Count, "B").End(xlUp).Row
For i = 0 To last_row \ PERIOD - 1
Sheets(1).Cells(PASTE_FROM_ROW + i, "B").Resize(, PERIOD) = _
WorksheetFunction.Transpose(Sheets(2).Cells(i * PERIOD + 1, "B").Resize(PERIOD))
Next
End Sub
Transpose a Column
Option Explicit
Sub TransposeColumn()
Const ProcName As String = "TransposeColumn"
On Error GoTo ClearError
Const sID As Variant = 2 ' or "Sheet2"
Const sFirst As String = "B1"
Const dID As Variant = 1 ' or "Sheet1"
Const dFirst As String = "B9"
Const dcCount As Long = 8
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Create a reference to the Source First Cell Range.
Dim sws As Worksheet: Set sws = wb.Worksheets(sID)
Dim sfCell As Range: Set sfCell = sws.Range(sFirst)
' Using the 'GetTransposedColumn' function, write the transposed data
' to the Destination Array.
Dim dData As Variant: dData = GetTransposedColumn(sfCell, dcCount)
If IsEmpty(dData) Then Exit Sub
' Create a reference to the Destination First Cell Range.
Dim dws As Worksheet: Set dws = wb.Worksheets(dID)
Dim dfCell As Range: Set dfCell = dws.Range(dFirst)
' Check if the values from the Destination Array fit
' into the Destination Worksheet.
Dim drCount As Long: drCount = UBound(dData, 1)
If drCount > dws.Rows.Count - dfCell.Row + 1 Then Exit Sub
If dcCount > dws.Columns.Count - dfCell.Column + 1 Then Exit Sub
' Create a reference to the Destination Range.
Dim drg As Range: Set drg = dfCell.Resize(drCount, dcCount)
' Write the values from the Destination Array to the Destination Range.
drg.Value = dData
' Clear the contents below the Destination Range.
With drg
Dim crCount As Long: crCount = .Worksheet.Rows.Count - .Row + 1
If crCount > drCount Then
.Resize(crCount - drCount).Offset(drCount).ClearContents
End If
End With
MsgBox "Data transposed.", vbInformation, ProcName
ProcExit:
Exit Sub
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the transposed values of a one-column range
' in a 2D one-based array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetTransposedColumn( _
ByVal FirstCell As Range, _
Optional ByVal ColumnsCount As Long = 1) _
As Variant
Const ProcName As String = "GetTransposedColumn"
On Error GoTo ClearError
If FirstCell Is Nothing Then Exit Function
If ColumnsCount < 1 Then Exit Function
Dim srg As Range
Dim srCount As Long
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
srCount = lCell.Row - .Row + 1
Set srg = .Resize(srCount)
End With
Dim sData As Variant
If srCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dcrCount As Long: dcrCount = Int(srCount / ColumnsCount)
Dim dcRem As Long: dcRem = srCount Mod ColumnsCount
Dim drCount As Long
If dcRem = 0 Then
drCount = dcrCount
Else
drCount = dcrCount + 1
End If
Dim dData As Variant: ReDim dData(1 To drCount, 1 To ColumnsCount)
Dim r As Long
Dim c As Long
Dim n As Long
If dcrCount > 0 Then
For r = 1 To dcrCount
For c = 1 To ColumnsCount
n = n + 1
dData(r, c) = sData(n, 1)
Next c
Next r
Else
r = 1
End If
If dcRem > 0 Then
For c = 1 To dcRem
n = n + 1
dData(r, c) = sData(n, 1)
Next c
End If
GetTransposedColumn = dData
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function
How can I autofill the entirety of column B based on column A but with n empty rows in between each letter?
Column A:
a
b
c
Column B:
a
...
...
b
...
...
c
I have tried the VBA code below:
Range("A1:A3").AutoFill Destination:=Range("A1:A10"), Type:=xlFillDefault
The code works with numbers but not when the cell references a formula (in this case, =A1, ...) as the code seems to reference the row the formula is, instead of the list in column A.
For example, the code inserts the formula a row after c in B7, however would insert =A7 instead of =A4 which would be the letter d.
Any help with this would be greatly appreciated.
To insert n row for each value in Column A, I will use offset to solve it, here is the solution and hope you find it useful:
Sub ty()
Dim count As Long, i As Long, nextrow As Long
count = Application.WorksheetFunction.CountA(Sheet1.Range("A:A"))
nextrow = 1
For i = 1 To count
Sheet1.Cells(nextrow, 2).Value = Sheet1.Cells(i, 1).Value
nextrow = Cells(nextrow, 2).Offset(3, 1).Row
Next
End Sub
Expected Output:
In order to preserve the formula into new cells, then you may need copy method` by change this part:
For i = 1 To count
Sheet1.Cells(i, 1).Copy Sheet1.Cells(nextrow, 2)
nextrow = nextrow + 3
Next
AutoFill Every n Rows
You run GetGappedColumnTEST. GetGappedColumn is being called by the GetGappedColumnTEST.
Adjust the values in the constants section and the workbook, and rename the Sub appropriately.
Option Explicit
Sub GetGappedColumnTEST()
Const sName As String = "Sheet1"
Const sFirst As String = "A1"
Const dName As String = "Sheet1"
Const dFirst As String = "B1"
Const dGap As Long = 2
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim Data As Variant
Data = GetGappedColumn(wb.Worksheets(sName).Range(sFirst), dGap)
If IsEmpty(Data) Then Exit Sub
Dim drCount As Long: drCount = UBound(Data, 1)
With wb.Worksheets(dName).Range(dFirst)
.Resize(drCount).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - drCount + 1) _
.Offset(drCount).ClearContents
End With
End Sub
Function GetGappedColumn( _
ByVal FirstCell As Range, _
Optional ByVal Gap As Long = 0) _
As Variant
Const ProcName As String = "GetGappedColumn"
On Error GoTo clearError
If FirstCell Is Nothing Then Exit Function
If Gap < 0 Then Exit Function
Dim srg As Range
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set srg = .Resize(lCell.Row - .Row + 1)
End With
Dim rCount As Long: rCount = srg.Rows.Count
Dim sData As Variant
If rCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
Else
sData = srg.Value
End If
Dim dData As Variant: ReDim dData(1 To rCount + rCount * Gap - Gap, 1 To 1)
Dim d As Long: d = 1
Dim s As Long
For s = 1 To rCount - 1
dData(d, 1) = sData(s, 1)
d = d + 1 + Gap
Next s
dData(d, 1) = sData(s, 1)
GetGappedColumn = dData
ProcExit:
Exit Function
clearError:
Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
& " " & "Run-time error '" & Err.Number & "':" & vbLf _
& " " & Err.Description
Resume ProcExit
End Function