Column A
Column B
Column C
Column D
John
22
David
87
Marcy
42
Kumar
23
Kumar
35
Marcy
42
David
21
John
33
In excel ordering Column C according Column A, the data of column C e D are to move together.
Ex: First row will be
Column A
Column B
Column C
Column D
John
22
John
33
I've tried excel functions like:
PROCV, VLOOKUP and the sort and filter button in excel with no luck.
Note:
All rows must be uniquely identified by the name in column a
You need to reference Microsoft Scripting Runtime
... anyway
Sub sheesh()
Set dict = CreateObject("Scripting.Dictionary")
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(1)
Dim lastRow As Long: lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
Dim i As Integer
For i = 1 To lastRow
dict.Add CStr(ws.Cells(i, 3).Value), CInt(ws.Cells(i, 4).Value)
Next i
For Each k In dict.Keys
Debug.Print k
Next
For i = 1 To lastRow
If dict.Exists(ws.Cells(i, 1).Value) Then
ws.Cells(i, 3).Value = ws.Cells(i, 1).Value
ws.Cells(i, 4).Value = dict(ws.Cells(i, 1).Value)
End If
Next i
End Sub
Align Data
Option Explicit
Sub AlignData()
Const fRow As Long = 1
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim Key As Variant
Dim r As Long
' Left two columns to left dictionary.
Dim llRow As Long: llRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Dim lCount As Long: lCount = llRow - fRow + 1
Dim lrg As Range: Set lrg = ws.Cells(fRow, "A").Resize(lCount, 2)
Dim lData As Variant: lData = lrg.Value
Dim lDict As Object: Set lDict = CreateObject("Scripting.Dictionary")
lDict.CompareMode = vbTextCompare
For r = 1 To lCount
Key = lData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
lDict(lData(r, 1)) = lDict(lData(r, 1)) + lData(r, 2) ' Sum
End If
End If
Next r
Erase lData
lCount = lDict.Count
' Right two columns to right dictionary.
Dim rlRow As Long: rlRow = ws.Cells(ws.Rows.Count, "C").End(xlUp).Row
Dim rCount As Long: rCount = rlRow - fRow + 1
Dim rrg As Range: Set rrg = ws.Cells(fRow, "C").Resize(rCount, 2)
Dim rData As Variant: rData = rrg.Value
Dim rDict As Object: Set rDict = CreateObject("Scripting.Dictionary")
rDict.CompareMode = vbTextCompare
For r = 1 To rCount
Key = rData(r, 1)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
rDict(rData(r, 1)) = rDict(rData(r, 1)) + rData(r, 2) ' Sum
End If
End If
Next r
Erase rData
rCount = rDict.Count
' Write to destination arrays.
ReDim lData(1 To lCount, 1 To 2) ' exact size
ReDim rData(1 To lCount + rCount, 1 To 2) ' oversized
r = 0
For Each Key In lDict.Keys
r = r + 1
lData(r, 1) = Key: lData(r, 2) = lDict(Key)
If rDict.Exists(Key) Then
rData(r, 1) = Key: rData(r, 2) = rDict(Key)
rDict.Remove Key
End If
Next Key
If rDict.Count > 0 Then
For Each Key In rDict.Keys
r = r + 1
rData(r, 1) = Key: rData(r, 2) = rDict(Key)
Next Key
End If
' Overwrite ranges.
With lrg
.Resize(lDict.Count).Value = lData
.Resize(ws.Rows.Count - .Row - lCount + 1).Offset(lCount).ClearContents
End With
With rrg
.Resize(r).Value = rData
.Resize(ws.Rows.Count - .Row - r + 1).Offset(r).ClearContents
End With
MsgBox "Data aligned.", vbInformation
End Sub
Related
I have 2 sheets with multiple rows and columns like this:
Sheet1:
I want to search each value from Sheet1, Column B in Sheet2, Column B then:
If the value is equal => Copy the rest of the row in sheet1.
At the end, sheet1 should look like this:
and Sheet2 the same, I don't modify in that, only I take from that the rest of the rows.
Thank you very much,
I have tried something like this:
Sub Compare()
Dim n As Integer
Dim sh As Worksheets
Dim r As Range
n = 1000
Dim match As Boolean
Dim valE As Double
Dim valI As Double
Dim I As Long, J As Long
For I = 2 To n
val1 = Worksheets("Sheet1").Range("B" & I).Value
val2 = Worksheets("Sheet2").Range("B" & I).Value
If val1 = val2 Then
Worksheets("Sheet1").Range("C" & I).Value = Worksheets("Sheet2").Range("C" & I)
Worksheets("Sheet1").Range("D" & I).Value = Worksheets("Sheet2").Range("D" & I)
Worksheets("Sheet1").Range("E" & I).Value = Worksheets("Sheet2").Range("E" & I)
I = I + 1
End If
Next I
Application.ScreenUpdating = True
End Sub
It works for 10 values or so, but I have 1200 values and it just doesn't do anything.
A VBA Lookup: Copy Rows
Type Wks
Name As String
LookupColumn As Long
FirstColumn As Long
End Type
Sub LookupData()
Dim Src As Wks
Src.Name = "Sheet2"
Src.LookupColumn = 2
Src.FirstColumn = 3
Dim Dst As Wks
Dst.Name = "Sheet1"
Dst.LookupColumn = 2
Dst.FirstColumn = 3
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Read source.
Dim sws As Worksheet: Set sws = wb.Worksheets(Src.Name)
Dim srg As Range, slData() As Variant, srCount As Long, cCount As Long
With sws.Range("A1").CurrentRegion
srCount = .Rows.Count - 1
cCount = .Columns.Count
If srCount = 0 Then Exit Sub
Set srg = .Resize(srCount).Offset(1)
End With
With srg.Columns(Src.LookupColumn)
If srCount = 1 Then
ReDim slData(1 To 1, 1 To 1): slData(1, 1) = .Value
Else
slData = .Value
End If
End With
Dim cOffset As Long: cOffset = Src.FirstColumn - 1
cCount = cCount - cOffset
Dim svData() As Variant
With srg.Resize(, cCount).Offset(, cOffset)
If srCount * cCount = 1 Then
ReDim svData(1 To 1, 1 To 1): svData = .Value
Else
svData = .Value
End If
End With
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim r As Long, cString As String
For r = 1 To srCount
cString = CStr(slData(r, 1))
If Not dict.Exists(cString) Then dict(cString) = r
Next r
' Read destination.
Dim dws As Worksheet: Set dws = wb.Worksheets(Dst.Name)
Dim drg As Range, dlData() As Variant, drCount As Long
With dws.Range("A1").CurrentRegion
drCount = .Rows.Count - 1
If drCount = 0 Then Exit Sub
Set drg = .Resize(drCount).Offset(1)
End With
With drg.Columns(Dst.LookupColumn)
If drCount = 1 Then
ReDim dlData(1 To 1, 1 To 1): dlData(1, 1) = .Value
Else
dlData = .Value
End If
End With
Dim dvData() As Variant: ReDim dvData(1 To drCount, 1 To cCount)
' Lookup and write to destination.
Dim dr As Long, c As Long
For r = 1 To drCount
cString = CStr(dlData(r, 1))
If dict.Exists(cString) Then
dr = dict(cString)
For c = 1 To cCount
dvData(r, c) = svData(dr, c)
Next c
End If
Next r
Dim dfCell As Range: Set dfCell = drg.Columns(Dst.FirstColumn).Cells(1)
Dim dvrg As Range: Set dvrg = dfCell.Resize(drCount, cCount)
dvrg.Value = dvData
' Inform.
MsgBox "Data copied.", vbInformation
End Sub
Good morning,
I have a table with values that increment in the rows from left to right and then they change again as soon as I go down further
I wanted to loop through the rows and set the values in these rows in a different sheet to go in column A from row 2 and then it increments from A2 --> A3 --> A4...etc.
Sub LoopthroughRows ()
LastRow = Range("O" & Rows.Count).End(xlUp).Row
FirstRow = 2
i = FirstRow
FirstColumn = 15
Do Until i > LastRow
LastColumn = Cells(i, Columns.Count).End(xlToLeft).Column
Count = FirstColumn
k = 2
Do Until Count > LastColumn
Set Worksheets(Sheet7).Range("A" & k).Value = Worksheets(Sheet5).Range(Chr(Count + 64) & i).Value
Count = Count + 1
Loop
k=k+1
i=i+1
Loop
End Sub
when I run the code it comes up with Run time error '13' type mismatch. I tested the run through rows function and it works. I believe the issue might be with the set function in my Do loop?
Please help! I am using this to convert the rows into 1 column.
Thank you and have a great week :)
Get Column From Range
A Quick Fix: Practicing Do Loops (Slow)
Sub LoopthroughRows()
Dim fCell As Range: Set fCell = Sheet5.Range("O2")
Dim FirstRow As Long: FirstRow = fCell.Row
Dim FirstColumn As Long: FirstColumn = fCell.Column
Dim LastRow As Long
LastRow = Sheet5.Cells(Sheet5.Rows.Count, FirstColumn).End(xlUp).Row
Dim sr As Long: sr = FirstRow
Dim dr As Long: dr = 2
Dim LastColumn As Long
Dim sc As Long
Do Until sr > LastRow
sc = FirstColumn
LastColumn = Sheet5.Cells(sr, Sheet5.Columns.Count).End(xlToLeft).Column
Do Until sc > LastColumn
Sheet7.Cells(dr, "A").Value = Sheet5.Cells(sr, sc).Value
sc = sc + 1
dr = dr + 1
Loop
sr = sr + 1
Loop
End Sub
An Improvement: Using a Function (Fast)
Sub GetColumnFromRangeTEST()
Dim sfCell As Range: Set sfCell = Sheet5.Range("O2")
Dim srg As Range
With sfCell.CurrentRegion
Set srg = sfCell.Resize(.Row + .Rows.Count - sfCell.Row, _
.Column + .Columns.Count - sfCell.Column)
End With
Dim Data() As Variant
' Read by rows:
Data = GetColumnFromRange(srg)
' Read by columns:
'Data = GetColumnFromRange(srg, True)
Dim dfCell As Range: Set dfCell = Sheet7.Range("A2")
Dim drg As Range: Set drg = dfCell.Resize(UBound(Data, 1))
drg.Value = Data
End Sub
Function GetColumnFromRange( _
ByVal rg As Range, _
Optional ByVal ReadByColumns As Boolean = False) _
As Variant()
Dim srCount As Long: srCount = rg.Rows.Count
Dim scCount As Long: scCount = rg.Columns.Count
Dim drCount As Long: drCount = srCount * scCount
Dim sData() As Variant
If drCount = 1 Then
ReDim sData(1 To 1, 1 To 1): sData(1, 1) = rg.Value
Else
sData = rg.Value
End If
Dim dData() As Variant: ReDim dData(1 To drCount, 1 To 1)
Dim sr As Long, sc As Long, dr As Long
If ReadByColumns Then
For sc = 1 To scCount
For sr = 1 To srCount
dr = dr + 1
dData(dr, 1) = sData(sr, sc)
Next sr
Next sc
Else
For sr = 1 To srCount
For sc = 1 To scCount
dr = dr + 1
dData(dr, 1) = sData(sr, sc)
Next sc
Next sr
End If
GetColumnFromRange = dData
End Function
If this is a simply swap of rows/columns, you can do this without looping:
Sub test()
With Sheets(1)
Dim sourceRng As Range: Set sourceRng = .Range(.Cells(1, 1), .Cells(4, 2))
.Cells(6, 6).Resize(sourceRng.Columns.Count, sourceRng.Rows.Count).Value = Application.Transpose(sourceRng)
End With
End Sub
Note that I use sourceRng.Columns.Count in the "row" place and sourceRng.Rows.Count in the "column" place for the resize.
Edit1:
Modifying to indicate how to utilize as a loop (untested):
Sub test()
With Sheets(1)
Dim i as Long
For i = firstRowSource to lastRowSource
Dim sourceRng As Range: Set sourceRng = .Range(.Cells(i, 1), .Cells(i, 2))
Dim targetColDest as Long: targetColDest = targetColDest + 1
.Cells(1, targetColDest ).Resize(sourceRng.Columns.Count,).Value = Application.Transpose(sourceRng)
Next i
End With
End Sub
This code converts rows to the one long column (values from 0 to 319)
Sub LoopthroughRows()
With ThisWorkbook
a = .Sheets(1).Range("O2").CurrentRegion
ReDim b(UBound(a, 1) * UBound(a, 2))
i = 0
For r = 1 To UBound(a, 1)
For c = 1 To UBound(a, 2)
b(i) = a(r, c)
i = i + 1
Next
Next
.Sheets(2).Range("A2").Resize(UBound(b)) = WorksheetFunction.Transpose(b)
End With
End Sub
My code below gives me a result with a unique customer codes base on Calculation sheet. However, I want to get my result base on the list that I have in Solution Sheet. Also want to run the macro within Solution Sheet. Any help will be appreciated.
Calculation Sheet
Solution Sheet
Sub cTotals()
Dim arr, arr2, arr3
Dim Calc As Worksheet: Set TS = Worksheets("Calculation")
Dim Sol As Worksheet: Set Sol = Worksheets("Solution")
Dim x As Long, i As Long, a As Long, c As Long, ct As Long
Dim GIVMM As Single, MSU As Double, Cases As Double
arr = Calc.Range("B2:H" & Cells(Rows.Count, 1).End(xlUp).Row)
arr2 = arr
With CreateObject("Scripting.Dictionary")
For x = LBound(arr) To UBound(arr)
If Not IsMissing(arr(x, 1)) Then .Item(arr(x, 1)) = 1
Next
arr = .Keys
End With
ReDim arr3(1 To UBound(arr) + 1, 1 To 7)
c = 1: ct = 1
For i = 0 To UBound(arr)
For a = 1 To UBound(arr2)
If arr2(a, 1) = arr(i) Then
arr3(i + 1, c) = arr(i)
arr3(i + 1, c + 1) = ct
ct = ct + 1
GIVMM = GIVMM + arr2(a, 5)
arr3(i + 1, c + 2) = GIVMM
MSU = MSU + arr2(a, 6)
arr3(i + 1, c + 3) = MSU
Cases = Cases + arr2(a, 7)
arr3(i + 1, c + 4) = Cases
End If
Next
ct = 1: GIVMM = 0: MSU = 0: Cases = 0
Next
Sol.Range("B6").Resize(UBound(arr3, 1), UBound(arr3, 2)) = arr3
End Sub
Using Data Structures (Array, Collection, Dictionary)
Option Explicit
Sub CalculateData()
' Define constants.
' Source
Const sName As String = "Calculation"
Const scCol As Long = 2
Dim sCols() As Variant: sCols = VBA.Array(4, 6, 7, 8)
' Destination
Const dName As String = "Solution"
Const dfRow As Long = 6
Const dcCol As Long = 2
Const dColumnOffset As Long = 1
Dim dOffsets() As Variant: dOffsets = VBA.Array(1, 2, 3, 4)
' Reference the workbook ('wb').
Dim wb As Workbook: Set wb = ThisWorkbook
' Write the values from the source range ('srg') to an array ('sData').
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim sData() As Variant: sData = srg.Value
Dim srCount As Long: srCount = srg.Rows.Count
' Write the unique source values to the 'keys' ('sString')
' of a dictionary ('sDict'). Its 'items' ('sDict(sString)') will hold
' a collection of all the (source) rows ('r') where the 'key' appeared.
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
sDict.CompareMode = vbTextCompare
Dim sString As String
Dim r As Long
For r = 2 To srCount
sString = CStr(sData(r, scCol))
If Len(sString) > 0 Then
If Not sDict.Exists(sString) Then
Set sDict(sString) = New Collection
End If
sDict(sString).Add r
End If
Next r
' Write the values from the destination lookup column range ('dlrg')
' to a 2D one-based (one-column) array ('dlData').
Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
Dim dlRow As Long: dlRow = dws.Cells(dws.Rows.Count, dcCol).End(xlUp).Row
Dim drCount As Long: drCount = dlRow - dfRow + 1
If drCount < 1 Then
MsgBox "No data in the destination column.", vbCritical
Exit Sub
End If
Dim dlrg As Range: Set dlrg = dws.Cells(dfRow, dcCol).Resize(drCount)
Dim dlData() As Variant
If drCount = 1 Then ' one cell
ReDim dlData(1 To 1, 1 To 1): dlData(1, 1) = dlrg.Value
Else ' multiple cells
dlData = dlrg.Value
End If
' Write the results to the destination array ('dData').
Dim cUpper As Long: cUpper = UBound(sCols)
Dim cCount As Long: cCount = cUpper + 1
Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount)
Dim dDict As Object: Set dDict = CreateObject("Scripting.Dictionary")
dDict.CompareMode = vbTextCompare
Dim sItem As Variant
Dim sValue As Variant
Dim dString As String
Dim c As Long
For r = 1 To drCount
dString = CStr(dlData(r, 1))
If Len(dString) > 0 Then
If sDict.Exists(dString) Then ' found in the dictionary
For Each sItem In sDict(dString) ' loop through the rows
For c = 0 To cUpper
If c = 0 Then ' unique count
sString = CStr(sData(sItem, sCols(c)))
dDict(sString) = Empty
Else ' sum
sValue = sData(sItem, sCols(c))
If VarType(sValue) = vbDouble Then ' is a number
dData(r, c + 1) = dData(r, c + 1) + sValue
'Else ' is not a number; do nothing
End If
End If
Next c
Next sItem
dData(r, 1) = dDict.Count
dDict.RemoveAll
' Else ' not found in the dictionary; do nothing
End If
' Else ' vbNullString ('""'); do nothing
End If
Next r
' Write the values from the destination array to the destination range.
With dws.Cells(dfRow, dcCol).Offset(, dColumnOffset)
.Resize(drCount, cCount).Value = dData
End With
' Inform.
MsgBox "Data calculated.", vbInformation
End Sub
I've been trying to tinker with this source code that transposes 1 column separated by spaces.
Sub Transpose()
Dim lastrow As Long, i As Long, j As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet
Application.ScreenUpdating = False
With Sheets("Sheet1")
Set ws = Sheets.Add(after:=Sheets(Sheets.Count))
lastrow = .Cells(Rows.Count, "A").End(xlUp).row
iStart = 1
For i = 1 To lastrow + 1
If .Range("A" & i).Value = "" Then
iEnd = i
j = j + 1
.Range(.Cells(iStart, 1), .Cells(iEnd, 1)).Copy
ws.Range("A" & j).PasteSpecial Paste:=xlPasteValues, Transpose:=True
iStart = iEnd + 1
End If
Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
I'm trying to take take 4 columns ranges with variable rows
[
And transpose each range adjacently so that it looks like this:
Any input appreciated.
Try this out:
Sub Transpose()
Dim ws As Worksheet, cCopy As Range, cPaste As Range
Set ws = Sheets("Sheet1")
Set cCopy = ws.Range("A1") 'top-left of first data block
Set cPaste = ws.Range("F1") 'first output cell
Do While Len(cCopy.Value) > 0 'while have data to transpose
With cCopy.CurrentRegion
Debug.Print "Copying", .Address, " to ", cPaste.Address
cPaste.Resize(.Columns.Count, .Rows.Count) = _
Application.Transpose(.Value)
Set cPaste = cPaste.Offset(.Columns.Count + 1) 'next paste position
Set cCopy = cCopy.Offset(.Rows.Count + 1) 'next data block
End With
Loop
End Sub
Took way too long to do this and the most atrocious architecture but it works.
r = 1
c = 1
cl = 6
rw = 1
For r = 1 To 13
For c = 1 To 4
If Cells(r, c) <> "" Then
Cells(rw, cl) = Cells(r, c)
rw = rw + 1
End If
Next
'If Cells(r, c) = "" Then cl = 6
rw = 1
cl = cl + 1
Next
rw = 5
cl = 6
For r = 1 To 4
For c = 10 To 12
Cells(rw, cl) = Cells(r, c)
cl = cl + 1
Next
rw = rw + 1
cl = 6
Next
rw = 9
cl = 6
For r = 1 To 4
For c = 14 To 18
Cells(rw, cl) = Cells(r, c)
cl = cl + 1
Next
rw = rw + 1
cl = 6
Next
Range("J1:R4").ClearContents
Try this code:
Sub SubRollData()
'Declarations.
Dim RngSource As Range
Dim RngTarget As Range
Dim DblRowOffset As Double
Dim DblColumnOffset As Double
'Settings.
Set RngSource = Range("A1")
Set RngTarget = Range("F1")
'Checkpoint for the block processing.
CP_Block:
'Covering each column.
For DblColumnOffset = 0 To 3
'Setting DblRowOffset to start covering for the first row of the block.
DblRowOffset = 0
'Covering each row of the block of the given column until an empty cell is fount.
Do Until RngSource.Offset(DblRowOffset, DblColumnOffset) = ""
'Reporting the data with switched offset.
RngTarget.Offset(DblColumnOffset, DblRowOffset).Value = RngSource.Offset(DblRowOffset, DblColumnOffset).Value
'Setting DblRowOffset for the next row.
DblRowOffset = DblRowOffset + 1
Loop
Next
'Setting RngSource to aim at the next block.
If RngSource.Offset(1, 0) = "" Then
Set RngSource = RngSource.Offset(2, 0)
Else
Set RngSource = RngSource.End(xlDown).Offset(2, 0)
End If
'Setting RngSource to aim at the next empty row to fill in with data.
If RngTarget.Offset(1, 0) = "" Then
Set RngTarget = RngTarget.Offset(1, 0)
Else
Set RngTarget = RngTarget.End(xlDown).Offset(1, 0)
End If
'If RngSource has no data, there is no more block to be processed. Otherwise, the next block is processed.
If RngSource.Value <> "" Then GoTo CP_Block
End Sub
It works with the example you've given and also with isoletd (single row) source data.
Just for fun, here is a possible formula based solution to be placed in cell F1 and dragged:
=IF(COLUMN(F1)-COLUMN($F1)+1>=AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4)+1)-IF(QUOTIENT(ROW(F1)-ROW(F$1),4)=0,0,AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4))),"",INDEX($A:$D,COLUMN(F1)-COLUMN($F1)+1+IF(QUOTIENT(ROW(F1)-ROW(F$1),4)=0,0,AGGREGATE(15,6,1/($A:$A="")*ROW($A:$A),QUOTIENT(ROW(F1)-ROW(F$1),4))),MOD(ROW(F1)-ROW(F$1),4)+1))
Naturally it's really heavy and stupidly complicated, but as i said: made it just for fun.
Transpose Groups of Data to a New Worksheet
Sub TransposeGroups()
' Source - use as-is (read (copy) from)
Const sName As String = "Sheet1"
Const sFirstRowAddress As String = "A1:D1"
Const sMandatoryColumnIndex As Long = 1 ' dictates if empty row (gap)
' Destination - delete if exists and put last (write (paste) to)
Const dName As String = "Result"
Const dFirstCellAddress As String = "A1"
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Write the values from the source range to a 2D one-based array
' and write its upper limits to variables.
Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
Dim sData As Variant
Dim srCount As Long
Dim scCount As Long
With sws.Range(sFirstRowAddress)
Dim lCell As Range
With .Columns(sMandatoryColumnIndex)
Set lCell = .Resize(sws.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
End With
If lCell Is Nothing Then
MsgBox "No data in column " & sMandatoryColumnIndex & ".", _
vbCritical
Exit Sub
End If
scCount = .Columns.Count
srCount = lCell.Row - .Row + 1
sData = .Resize(srCount).Value
End With
' Loop through the rows of the source array and map the first row,
' the last row and the following gap count (empty rows) in each row
' of three columns of another 2D one-based array.
' Note that this array has the same number of rows as the source array,
' but the data of interest will be in much fewer rows ('mr').
' (Probably a collection of collections (or three element arrays)
' would have been a better choice.)
Dim mArr() As Long: ReDim mArr(1 To srCount, 1 To 3)
Dim sr As Long
Dim sValueFound As Boolean
Dim mr As Long
Dim ccCount As Long
Dim dcCount As Long
Dim GapCount As Long
For sr = 1 To srCount
If Len(CStr(sData(sr, sMandatoryColumnIndex))) > 0 Then
If Not sValueFound Then
mr = mr + 1
mArr(mr, 1) = sr ' first row
sValueFound = True
End If
Else
If sValueFound Then
sValueFound = False
mArr(mr, 2) = sr - 1 ' last row
ccCount = sr - mArr(mr, 1)
If ccCount > dcCount Then dcCount = ccCount
End If
mArr(mr, 3) = mArr(mr, 3) + 1 ' gap
GapCount = GapCount + 1 ' to determine the number of rows of 'dData'
End If
Next sr
' The very last row (of interest).
mArr(mr, 2) = srCount
ccCount = sr - mArr(mr, 1)
If ccCount > dcCount Then dcCount = ccCount
' Using the source array and the information from the mapping array,
' write the results to the destination array.
Dim drCount As Long: drCount = mr * scCount + GapCount
Dim dData As Variant: ReDim dData(1 To drCount, 1 To dcCount)
Dim drFirst As Long
Dim sc As Long
Dim dc As Long
For mr = 1 To mr
For sc = 1 To scCount
For sr = mArr(mr, 1) To mArr(mr, 2)
dc = dc + 1
dData(drFirst + sc, dc) = sData(sr, sc)
Next sr
dc = 0
Next sc
drFirst = drFirst + sc + mArr(mr, 3) - 1
Next mr
' Write the values from the destination array to a new worksheet.
' Check if a sheet with the same name exists.
Dim dsh As Object
On Error Resume Next
Set dsh = wb.Sheets(dName)
On Error GoTo 0
' If it exists, delete it without confirmation.
If Not dsh Is Nothing Then
Application.DisplayAlerts = False
dsh.Delete
Application.DisplayAlerts = True
End If
' Add a new worksheet and rename it accordingly.
Dim dws As Worksheet
Set dws = wb.Worksheets.Add(After:=wb.Sheets(wb.Sheets.Count))
dws.Name = dName
' Write the values from the destination array to the destination worksheet.
With dws.Range(dFirstCellAddress)
.Resize(drCount, dcCount).Value = dData
End With
' Inform.
MsgBox "Groups transposed.", vbInformation
End Sub
My Intention:
I wanna select all values in Rows "B" and "C" and move these 1 and 2 steps up.
The Example for what I have:
A
B
C
AA
Two
AA
Three
Two
AA
Three
Two
Three
X
yy
CC
The Example for what I would: If in Column-A find "X" should YY and CC delet
A
B
C
AA
Two
Three
AA
Two
Three
AA
Two
Three
My Code:
Sub test()
ActiveSheet.Select
Range("B:B").Select Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C:C").Select Shift:=xlUp, CopyOrigin:=xlFormatFromLeftOrAbove
End Sub
I would be happy if somebody help me
Align Data
Option Explicit
Sub AlignData()
Const Cols As String = "A:C"
Const fRow As Long = 1
Const ExceptionsList As String = "XX" ' comma-separated, no spaces!
Const Gap As Long = 1 ' number of empty rows in-between
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the source range.
Dim srg As Range
Dim srCount As Long
With ws.Rows(fRow).Columns(Cols).Resize(ws.Rows.Count - fRow + 1)
Dim lrCell As Range
Set lrCell = .Find("*", , xlFormulas, , xlByRows, xlPrevious)
If lrCell Is Nothing Then Exit Sub ' no data
srCount = lrCell.Row - fRow + 1
Set srg = .Resize(srCount)
End With
Dim cCount As Long: cCount = srg.Columns.Count
' 1 to hold each column array
' 2 to hold a collection of each column's matching values
Dim jArr As Variant: ReDim jArr(1 To cCount, 1 To 2)
Dim Exceptions() As String: Exceptions = Split(ExceptionsList, ",")
Dim crg As Range
Dim c As Long
Dim r As Long
Dim sValue As Variant
' Write the column arrays to the jagged array.
For c = 1 To cCount
jArr(c, 1) = srg.Columns(c).Value ' column arrays
Set jArr(c, 2) = New Collection ' to hold the matching values
Next c
' Use a dictionary to hold the indexes of (unwanted) exception matches.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim dStep As Long: dStep = Gap + 1
Dim dData As Variant
Dim drCount As Long
Dim dr As Long
Dim sr As Long
For c = 1 To cCount
dr = 0
For sr = 1 To srCount
sValue = jArr(c, 1)(sr, 1)
If Not IsEmpty(sValue) Then ' exclude empty values
dr = dr + 1
If c = 1 Then ' 1st array
If IsError(Application.Match(sValue, Exceptions, 0)) Then
jArr(c, 2).Add sValue
Else ' found in exceptions
dict(dr) = Empty ' add the index
End If
Else ' all but the 1st array
If Not dict.Exists(dr) Then
jArr(c, 2).Add sValue
End If
End If
End If
Next sr
' Write the values from the collection to the destination array.
If c = 1 Then
drCount = jArr(c, 2).Count * dStep - 1
ReDim dData(1 To drCount, 1 To cCount)
End If
For sr = 1 To drCount Step dStep
dData(sr, c) = jArr(c, 2)(Int(sr / dStep) + 1)
Next sr
Set jArr(c, 2) = Nothing
Next c
' Write the values from the destination array to the range and clear below.
With srg.Resize(drCount)
.Value = dData
.Resize(ws.Rows.Count - .Row - drCount + 1).Offset(drCount).Clear
End With
End Sub
select all cells (A1:C5) and start the following macro
Sub FillCells()
Dim rngCell As Range
Do Until Application.WorksheetFunction.CountBlank(Selection) = 0
For Each rngCell In Selection
If rngCell.Value = "" Then
rngCell.Value = rngCell.Offset(1, 0).Value
End If
Next rngCell
Loop
End Sub
Best regards
Bernd