I want to delete all rows in excel sheet if specific column value starts with 1.
For example, if range of A1:A having values starts with 1 then I want to delete all those rows using excel vba.
How to get it?
Dim c As Range
Dim SrchRng
Set SrchRng = Sheets("Output").UsedRange
Do
Set c = SrchRng.Find("For Men", LookIn:=xlValues)
If Not c Is Nothing Then c.EntireRow.Delete
Loop While Not c Is Nothing
Here's the required code with comments on how it works. Feed the worksheet and column number to the sub and call it e.g. Delete Rows 2, Sheets("myWorksheet"):
Sub DeleteRows(columnNumber as Integer, ws as WorkSheet)
Dim x as long, lastRow as Long
' get the last used row
lastRow = ws.cells(1000000, columnNumber).end(xlUp).Row
'loop backwards from the last row and delete applicable rows
For x = lastRow to 1 Step -1
' if the cell starts with a number...
If IsNumeric(Left(ws.Cells(x, columnNumber), 1) Then
'Delete it the row if it's equaal to 1
If Left(ws.Cells(x, columnNumber), 1) = 1 Then ws.Rows(x &":"& x).Delete
End If
Next x
End Sub
Dim Value As String
Dim CellName As String
Dim RowNumber As Long
Do While Value <> ""
CellName = "A" + RowNumber
Value = ActiveSheet.Cells(GetRowNumber(CellName), GetColumnNumber(CellName)).Value
If Mid(Value, 1, 1) = "2" Then
ActiveSheet.Range("A" & RowNumber).EntireRow.Delete
End If
RowNumber = RowNumber + 1
Loop
Private Function GetColumnNumber(ByVal CellName As String) As Long
For L = 1 To 26
If Left(CellName, 1) = Chr(L + 64) Then
GetColumnNumber = L
Exit For
End If
Next
End Function
Private Function GetRowNumber(ByVal CellName As String) As Long
GetRowNumber = CLng(Mid(CellName, 2))
End Function
You may be pushing the bounds of what is reasonable to do in Excel vba.
Consider importing the Excel file into Microsoft Access.
Then, you can write 2 Delete Queries and they will run uber fast:
DELETE FROM MyTable WHERE col1 like '2*'
DELETE FROM MyTable WHERE col2 LIKE '*for men*' OR col3 LIKE '*for men*'
After deleting those records, you can export the data to a new Excel file.
Also, you can write an Access Macro to import the Excel File, run the Delete Queries, and Export the data back to Excel.
And you can do all of this without writing a line of VBA Code.
You can try:
Sub delete()
tamano = Range("J2") ' Value into J2
ifrom = 7 ' where you want to delete
'Borramos las celdas
'Delete column A , B and C
For i = ifrom To tamano
Range("A" & i).Value = ""
Range("B" & i).Value = ""
Range("C" & i).Value = ""
Next i
End Sub
Related
I am not that much familiar in VBA code. I am looking to implement two scenarios using VBA code in excel.
Scenario 1: If the value in the "C" column contains specific text, then replace the corresponding values in the "A" column as below
If the value in C contains "abc" then A= "abc".
If the value in C contains "gec" then A= "GEC".
It should loop from the second row to last non-empty row
A
B
C
Two
abc-def
Thr
gec-vdg
Thr
abc-ghi
Expected Result:
A
B
C
abc
Two
abc-def
gec
Thr
gec-vdg
abc
Thr
abc-ghi
Scenario 2: If the value in the "B" column is "A", then replace all the "A" value in the B column as "Active". If the value in the "B" column is I", then replace all the I value in the B column as inactive.
It should loop from the second row to last non-empty row
A
B
C
abc
A
abc-def
gec
I
gec-vdg
abc
A
abc-ghi
Expected Result:
A
B
C
abc
Active
abc-def
gec
Inactive
gec-vdg
abc
Active
abc-ghi
I know that it is possible by using excel formulas. Wondering, how it can be implemented using vba code in excel.
Usually people on here won't just write code for you, this is more for helping you with your code when your stuck. However I've written one for you based on the information you have provided. I've assumed your cells in column C would always have the hyphen and you always want what's left of the hyphen. If there is no hyphen or the relevant cell in column C is empty then nothing will be put into the relevant cell in column A.
I've put in to turn off ScreenUpdating for the code as I don't know how many rows you have. If it's a lot and you have a lot going on, then we can also turn off Calculation and Events to speed it up more, or run it as an array if it's really slow but I suspect that it won't be an issue.
Paste this into your relevant sheet module and change the sheet name as well as the column that's finding the last row if C isn't the right one:
Sub UpdateCells()
Application.ScreenUpdating = False
Dim i As Long, lRow As Long, ws As Worksheet
Set ws = Sheets("Sheet1") 'Change Sheet1 to your sheet name
lRow = ws.Range("C" & Rows.Count).End(xlUp).Row 'Finds your last row using Column C
With ws
For i = 2 To lRow 'Loop from row 2 to last row
If .Range("B" & i) = "A" Then
.Range("B" & i) = "Active"
ElseIf .Range("B" & i) = "I" Then
.Range("B" & i) = "Inactive"
End If
If .Range("C" & i) <> "" Then
If InStr(.Range("C" & i), "-") > 0 Then 'If current row Column C contains hyphen
.Range("A" & i) = Left(.Range("C" & i), InStr(.Range("C" & i), "-") - 1)
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
Replace Values
Option Explicit
Sub replaceCustom()
' Define constants.
Const wsName As String = "Sheet1"
Const ColumnsAddress As String = "A:C"
Const FirstRow As Long = 2
Dim Contains As Variant: Contains = VBA.Array(3, 1) ' 0-read, 1-write
Const findContainsList As String = "abc,gec" ' read
Const replContainsList As String = "abc,gec" ' write
Dim Equals As Variant: Equals = VBA.Array(2, 2) ' 0-read, 1-write
Const findEqualsList As String = "A,I" ' read
Const replEqualsList As String = "Active,Inactive" ' write
Dim CompareMethod As VbCompareMethod: CompareMethod = vbTextCompare
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook ' Workbook containing this code.
' Define range.
Dim rng As Range
With wb.Worksheets(wsName).Columns(ColumnsAddress)
Set rng = .Resize(.Worksheet.Rows.Count - FirstRow + 1) _
.Offset(FirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - FirstRow + 1).Offset(FirstRow - 1)
End With
' Write values from range to array.
Dim Data As Variant: Data = rng.Value
' Write lists to arrays.
Dim findCo() As String: findCo = Split(findContainsList, ",")
Dim replCo() As String: replCo = Split(replContainsList, ",")
Dim findEq() As String: findEq = Split(findEqualsList, ",")
Dim replEq() As String: replEq = Split(replEqualsList, ",")
' Modify values in array.
Dim i As Long
Dim n As Long
For i = 1 To UBound(Data, 1)
For n = 0 To UBound(Contains)
If InStr(1, Data(i, Contains(0)), findCo(n), CompareMethod) > 0 Then
Data(i, Contains(1)) = replCo(n)
Exit For
End If
Next n
For n = 0 To UBound(Equals)
If StrComp(Data(i, Equals(0)), findEq(n), CompareMethod) = 0 Then
Data(i, Equals(1)) = replEq(n)
Exit For
End If
Next n
Next i
' Write values from array to range.
rng.Value = Data
End Sub
basically I need to split a cell that has a few values, seperated by a comma into more cells. Then i need to create the exact amount of the cells under the new cells to be able to transpose this range later to have a new table.
In the picture you can see an example of what I have and what I need. I needed to anonymyze the data. Also I have hundreds of rows that need to changed like the 2 in the example.
Ths is my current code:
Sub texttocolumns()
Dim rng As Range
Dim x As Integer
x = ActiveSheet.UsedRange.Rows.Count
For i = x - 2 To 1
Cells(2 + i, 8).texttocolumns _
Destination:=Cells(2 + i, 9), _
Comma:=True
k = Application.WorksheetFunction.CountA("A" & "2 + i"" & "":" & "AT1")
Cells(2 + i, 1).Rows(k).Insert
Next i
End Sub
I can't find my mistake at the moment, could someone please help me out? thanks!
Since the output result is posted to a different location the expensive task of inserting rows can be avoided.
Try this procedure, which also avoids working with the source range by generating from it two Arrays:
An array containing the fixed fields
An array containing the field that needs to be split
The Procedure:
Sub Range_Split_A_Field()
Dim wsTrg As Worksheet, rgOutput As Range
Dim aFld_1To5 As Variant, aFld_6 As Variant
Dim aFld As Variant
Dim lRow As Long, L As Long
lRow = 3
Set wsTrg = ThisWorkbook.Sheets("Sht(2)")
Application.Goto wsTrg.Cells(1), 1
With wsTrg.Cells(lRow, 1).CurrentRegion
Set rgOutput = .Rows(1).Offset(0, 10)
.Rows(1).Copy
rgOutput.PasteSpecial
Application.CutCopyMode = False
aFld_1To5 = .Offset(1, 0).Resize(-1 + .Rows.Count, 5).Value2
aFld_6 = .Offset(1, 5).Resize(-1 + .Rows.Count, 1).Value2
End With
lRow = 1
For L = 1 To UBound(aFld_1To5)
aFld = aFld_6(L, 1)
If aFld = vbNullString Then
rgOutput.Offset(lRow).Resize(1, 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(1, 1).Value = aFld
lRow = 1 + lRow
Else
aFld = Split(aFld, Chr(44))
aFld = WorksheetFunction.Transpose(aFld)
rgOutput.Offset(lRow).Resize(UBound(aFld), 5).Value = WorksheetFunction.Index(aFld_1To5, L, 0)
rgOutput.Offset(lRow, 5).Resize(UBound(aFld), 1).Value = aFld
lRow = lRow + UBound(aFld)
End If: Next
End Sub
Please see the following pages for a better understanding of the resources used:
Application.Goto Method (Excel)
With Statement
Range Object (Excel)
Chr Function
UBound Function
WorksheetFunction Object (Excel)
Would something like this work:
'A1 = A,B,C,D,E,F,G
'A2 = 1,2,3,4,5,6,7
'A3 = A!B!C!D!E!F!G
'Test procedure will result in:
'A - G in cells A1:A7
'1,2,3,4,5,6,7 in cell A8.
'A - G in cells A9:A15
Sub Test()
TextToColumns Sheet1.Range("A1")
TextToColumns Sheet1.Range("A9"), "!"
End Sub
Public Sub TextToColumns(Target As Range, Optional Delimiter As String = ",")
Dim rng As Range
Dim lCount As Long
Dim x As Long
'How many delimiters in target string?
lCount = Len(Target) - Len(Replace(Target, Delimiter, ""))
'Add the blank rows.
For x = 1 To lCount + 1
Target.Offset(1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next x
'Split the string.
Target.TextToColumns Target, xlDelimited, xlTextQualifierNone, , , , , , True, Delimiter
'Use TRANSPOSE formula to paste to rows and then remove formula.
With Target.Offset(1).Resize(lCount + 1, 1)
.FormulaArray = "=TRANSPOSE(R" & Target.Row & "C:R" & Target.Row & "C" & lCount + 1 & ")"
.Value = .Value
End With
'Delete the original text string.
Target.EntireRow.Delete
End Sub
Edit:
To use from the Macro dialog box you could add this small procedure:
Public Sub Test()
Dim y As Long
y = ActiveSheet.UsedRange.Rows.Count
With ActiveSheet
For y = 5 To 1 Step -1
TextToColumns .Cells(y, 1)
Next y
End With
End Sub
Note: ActiveSheet.UsedRange.Rows.Count is a terrible way to find the last row.
See this thread: Error in finding last used cell in VBA
I have values in column B separated by commas. I need to split them into new rows and keep the other data the same.
I have a variable number of rows.
I don't know how many values will be in the cells in Column B, so I need to loop over the array dynamically.
Example:
ColA ColB ColC ColD
Monday A,B,C Red Email
Output:
ColA ColB ColC ColD
Monday A Red Email
Monday B Red Email
Monday C Red Email
Have tried something like:
colArray = Split(ws.Cells(i, 2).Value, ", ")
For i = LBound(colArray) To UBound(colArray)
Rows.Insert(i)
Next i
Try this, you can easily adjust it to your actual sheet name and column to split.
Sub splitByColB()
Dim r As Range, i As Long, ar
Set r = Worksheets("Sheet1").Range("B999999").End(xlUp)
Do While r.row > 1
ar = Split(r.value, ",")
If UBound(ar) >= 0 Then r.value = ar(0)
For i = UBound(ar) To 1 Step -1
r.EntireRow.Copy
r.Offset(1).EntireRow.Insert
r.Offset(1).value = ar(i)
Next
Set r = r.Offset(-1)
Loop
End Sub
You can also just do it in place by using a Do loop instead of a For loop. The only real trick is to just manually update your row counter every time you insert a new row. The "static" columns that get copied are just a simple matter of caching the values and then writing them to the inserted rows:
Dim workingRow As Long
workingRow = 2
With ActiveSheet
Do While Not IsEmpty(.Cells(workingRow, 2).Value)
Dim values() As String
values = Split(.Cells(workingRow, 2).Value, ",")
If UBound(values) > 0 Then
Dim colA As Variant, colC As Variant, colD As Variant
colA = .Cells(workingRow, 1).Value
colC = .Cells(workingRow, 3).Value
colD = .Cells(workingRow, 4).Value
For i = LBound(values) To UBound(values)
If i > 0 Then
.Rows(workingRow).Insert xlDown
End If
.Cells(workingRow, 1).Value = colA
.Cells(workingRow, 2).Value = values(i)
.Cells(workingRow, 3).Value = colC
.Cells(workingRow, 4).Value = colD
workingRow = workingRow + 1
Next
Else
workingRow = workingRow + 1
End If
Loop
End With
This will do what you want.
Option Explicit
Const ANALYSIS_ROW As String = "B"
Const DATA_START_ROW As Long = 1
Sub ReplicateData()
Dim iRow As Long
Dim lastrow As Long
Dim ws As Worksheet
Dim iSplit() As String
Dim iIndex As Long
Dim iSize As Long
'Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With ThisWorkbook
.Worksheets("Sheet4").Copy After:=.Worksheets("Sheet4")
Set ws = ActiveSheet
End With
With ws
lastrow = .Cells(.Rows.Count, ANALYSIS_ROW).End(xlUp).Row
End With
For iRow = lastrow To DATA_START_ROW Step -1
iSplit = Split(ws.Cells(iRow, ANALYSIS_ROW).Value2, ",")
iSize = UBound(iSplit) - LBound(iSplit) + 1
If iSize = 1 Then GoTo Continue
ws.Rows(iRow).Copy
ws.Rows(iRow).Resize(iSize - 1).Insert
For iIndex = LBound(iSplit) To UBound(iSplit)
ws.Cells(iRow, ANALYSIS_ROW).Offset(iIndex).Value2 = iSplit(iIndex)
Next iIndex
Continue:
Next iRow
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
End Sub
A formula solution is close to your requirement.
Cell G1 is the delimiter. In this case a comma.
Helper E1:=SUM(E1,LEN(B1)-LEN(SUBSTITUTE(B1,$H$1,"")))+1
You must fill the above formula one row more.
A8:=a1
Fill this formula to the right.
A9:=LOOKUP(ROW(1:1),$E:$E,A:A)&""
Fill this formula to the right and then down.
B9:=MID($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))+1,FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)+1))-FIND("艹",SUBSTITUTE($H$1&LOOKUP(ROW(A1),E:E,B:B)&$H$1,$H$1,"艹",ROW(A2)-LOOKUP(ROW(A1),E:E)))-1)&""
Fill down.
Bug:
Numbers will be converted to Text. Of course you can remove the &"" at the end of the formula, but blank cells will be filled with 0.
Given #A.S.H.'s excellent and brief answer, the VBA function below might be a bit of an overkill, but it will hopefully be of some help to someone looking for a more "generic" solution. This method makes sure not to modify the cells to the left, to the right, or above the table of data, in case the table does not start in A1 or in case there is other data on the sheet besides the table. It also avoids copying and inserting entire rows, and it allows you to specify a separator other than a comma.
This function happens to have similarities to #ryguy72's procedure, but it does not rely on the clipboard.
Function SplitRows(ByRef dataRng As Range, ByVal splitCol As Long, ByVal splitSep As String, _
Optional ByVal idCol As Long = 0) As Boolean
SplitRows = True
Dim oldUpd As Variant: oldUpd = Application.ScreenUpdating
Dim oldCal As Variant: oldCal = Application.Calculation
On Error GoTo err_sub
'Modify application settings for the sake of speed
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Get the current number of data rows
Dim rowCount As Long: rowCount = dataRng.Rows.Count
'If an ID column is specified, use it to determine where the table ends by finding the first row
' with no data in that column
If idCol > 0 Then
With dataRng
rowCount = .Offset(, idCol - 1).Resize(, 1).End(xlDown).Row - .Row + 1
End With
End If
Dim splitArr() As String
Dim splitLb As Long, splitUb As Long, splitI As Long
Dim editedRowRng As Range
'Loop through the data rows to split them as needed
Dim r As Long: r = 0
Do While r < rowCount
r = r + 1
'Split the string in the specified column
splitArr = Split(dataRng.Cells(r, splitCol).Value & "", splitSep)
splitLb = LBound(splitArr)
splitUb = UBound(splitArr)
'If the string was not split into more than 1 item, skip this row
If splitUb <= splitLb Then GoTo splitRows_Continue
'Replace the unsplit string with the first item from the split
Set editedRowRng = dataRng.Resize(1).Offset(r - 1)
editedRowRng.Cells(1, splitCol).Value = splitArr(splitLb)
'Create the new rows
For splitI = splitLb + 1 To splitUb
editedRowRng.Offset(1).Insert 'Add a new blank row
Set editedRowRng = editedRowRng.Offset(1) 'Move down to the next row
editedRowRng.Offset(-1).Copy Destination:=editedRowRng 'Copy the preceding row to the new row
editedRowRng.Cells(1, splitCol).Value = splitArr(splitI) 'Place the next item from the split string
'Account for the new row in the counters
r = r + 1
rowCount = rowCount + 1
Next
splitRows_Continue:
Loop
exit_sub:
On Error Resume Next
'Resize the original data range to reflect the new, full data range
If rowCount <> dataRng.Rows.Count Then Set dataRng = dataRng.Resize(rowCount)
'Restore the application settings
If Application.ScreenUpdating <> oldUpd Then Application.ScreenUpdating = oldUpd
If Application.Calculation <> oldCal Then Application.Calculation = oldCal
Exit Function
err_sub:
SplitRows = False
Resume exit_sub
End Function
Function input and output
To use the above function, you would specify
the range containing the rows of data (excluding the header)
the (relative) number of the column within the range with the string to split
the separator in the string to split
the optional (relative) number of the "ID" column within the range (if a number >=1 is provided, the first row with no data in this column will be taken as the last row of data)
The range object passed in the first argument will be modified by the function to reflect the range of all the new data rows (including all inserted rows). The function returns True if no errors were encountered, and False otherwise.
Examples
For the range illustrated in the original question, the call would look like this:
SplitRows Range("A2:C2"), 2, ","
If the same table started in F5 instead of A1, and if the data in column G (i.e. the data that would fall in column B if the table started in A1) was separated by Alt-Enters instead of commas, the call would look like this:
SplitRows Range("F6:H6"), 2, vbLf
If the table contained the row header plus 10 rows of data (instead of 1), and if it started in F5 again, the call would look like this:
SplitRows Range("F6:H15"), 2, vbLf
If there was no certainty about the number of rows, but we knew that all the valid rows are contiguous and always have a value in column H (i.e. the 3rd column in the range), the call could look something like this:
SplitRows Range("F6:H1048576"), 2, vbLf, 3
In Excel 95 or lower, you would have to change "1048576" to "16384", and in Excel 97-2003, to "65536".
I have a VBA macro which is currently copying data from Setup sheet and updating into the respective tables into Read_Only sheet for the first time. But when I click second time, it is adding the data into the respective tables in Read_Only sheet.
Now what I want is, if I click second time, it should first clear the existing data from that respective table in Read_Only sheet and then update the new data into that table. (For example: In 1st table, there were 10 rows of data, now when I click 2nd time I have only 8 rows of data, then macro should clear data existing 10 rows of data and update this new 8 rows of data and then delete the 2 empty two rows. This should be Dynamic, since number of rows may vary every time while updating new data)
Here is the existing code:
Sub copyData()
Dim wsSet As Worksheet
Dim wsRead As Worksheet
Dim rngSearch As Range
Dim lastRow As Integer
Dim i As Integer
Dim wRow As Integer
Dim strCat As String
Dim catRow As Integer
Set wsSet = ActiveWorkbook.Worksheets("Budget_Setup")
Set wsRead = ActiveWorkbook.Worksheets("WBS_Overview_Read_only")
Set rngSearch = wsRead.Range("A12:A1000") 'range in READ to search for category
lastRow = wsSet.Range("B16").End(xlDown).Row 'last row of data in SET
Application.ScreenUpdating = False
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1
If wsRead.Range("e" & wRow).Value <> "" Then
wsRead.Range("a" & wRow).EntireRow.Insert
End If
End If
wsSet.Range("b" & i & ":f" & i).Copy
wsRead.Range("a" & wRow).PasteSpecial
Application.CutCopyMode = False
Next i
Application.ScreenUpdating = True
Set wsRead = Nothing
Set wsSet = Nothing
End Sub
This code will first delete all the existing data in each of the sections on the Read_Only sheet; then, with one modification, your code can be run as is.
Add this line of code immediately after Application.ScreenUpdating = False
' Erase all data in the Read Only Sheet
Set currentData = wsRead.Columns(4).Find("Subject")
Do
wsRead.Range(currentData.Offset(2, 0), _
currentData.Offset(2, 0).End(xlDown).Offset(-1, 0)).EntireRow.Delete
Set currentData = wsRead.Columns(4).FindNext(currentData)
Loop Until Not currentData Is Nothing And currentData.Row = 12
This code uses the "Subject" and the "Budgeted Cost" cells to delete the existing data between it.
Next, add the following line of code immediately after wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert
this will add the first blank row of data to a given section. Your existing code will then insert the new data into the blank row
See if this works for you. I added one line to your code:
For i = 17 To lastRow
strCat = Left(wsSet.Range("b" & i).Value, 3) 'current category in SET
catRow = rngSearch.Find(strCat).Row 'row of match in READ
If wsRead.Range("a" & catRow + 1).Value = "" Then 'find the correct row to copy into
wRow = catRow + 1
wsRead.Rows(wRow).EntireRow.Insert 'I added this line
Else
wRow = wsRead.Range("a" & catRow).End(xlDown).Row + 1 'end of data
If wsRead.Range("e" & wRow).Value <> "" Then
Now, run this code before running yours.
Sub deletePhases()
' delete phases in Setup from ReadOnly
Dim r As Range, Col As Collection
Dim x As Long, l As Long
With Budget_Setup
Set r = .Range("b17", .Cells(.Rows.Count, 2).End(xlUp))
End With
If r.Row < 17 Then Exit Sub 'no data
Set Col = New Collection 'build unique list
On Error Resume Next
For x = 1 To r.Rows.Count
Col.Add Left(r(x).Value, 3), Left(r(x).Value, 3)
Next x
With ReadOnly
For x = 1 To Col.Count
l = .Columns(1).Find(Col(x)).Offset(1).Row '1 below heading
Do Until .Cells(l, 1) = "" 'end of phase data
.Rows(l).Delete
Loop
Next x
End With
End Sub
I'm not sure how you're defining your Phase.71, Phase.72, etc, ranges, but with the information we have, this might work for you.
Sub clearAll()
Dim r As Range, vArr, v
vArr = Array("Phase.71", "Phase.72", "Phase.73", "Phase.74", "Phase.75")
For Each v In vArr
Set r = ReadOnly.Range(v)
Set r = r.Offset(2).Resize(r.Rows.Count - 4)
r.ClearContents
Next v
End Sub
I am trying to get Excel data, which was mapped using a grid/matrix mapping into a de-normalized for so that i can enter the data into a database.
How do you copy data in a grid from one excel sheet to the other as follow illustrated below.
I was trying something like this... but as you can see, i am far off!
Sub NormaliseList(mySelection As Range)
Dim cell As Range
Dim i As Long
i = 1
For Each cell In mySelection
If cell <> "" Then
Sheets(2).Range("A" & i).Value = cell(cell.Row, 1).Value
Sheets(2).Range("B" & i).Value = cell.Value
Sheets(2).Range("C" & i).Value = cell(1, cell.Column).Value
i = i + 1
Next cell
End Sub
For Reference. I Updated my code..
Simply add the code, assign macro shortcut to the function
Select the range that contains the intersection data (not the row and column data)
Run macro (Beware, sheet 2 will have data added in normalised form)
If there are multiple headings that are needed i figured i would consolidate into one column then perform a "text to columns" after processing.
Sub NormaliseList()
' to run - assign macro shortcut to sub - Select Intersection data (not row and column headings and run)
Dim Rowname, ColumnName, IntValue As String
Dim x, cntr As Integer
Dim test As Boolean
cntr = 0
For x = 1 To Selection.Count
If Selection(x).Value <> "" Then
cntr = cntr + 1
Rowname = ActiveSheet.Cells(Selection.Cells(x).Row, Selection.Column - 1)
ColumnName = ActiveSheet.Cells(Selection.Row - 1, Selection.Cells(x).Column)
IntValue = Selection(x).Value
test = addrecord(Rowname, ColumnName, IntValue, cntr)
End If
Next x
End Sub
Function addrecord(vA, vB, vC As String, rec As Integer) As Boolean
'Make sure that you have a worksheet called "Sheet2"
Sheets("Sheet2").Cells(rec, 1) = vA
Sheets("Sheet2").Cells(rec, 2) = vB
Sheets("Sheet2").Cells(rec, 3) = vC
End Function
I've got two posts, with usable code and downloadable workbook, on doing this in Excel/VBA on my blog:
http://yoursumbuddy.com/data-normalizer
http://yoursumbuddy.com/data-normalizer-the-sql/
Here's the code:
'Arguments
'List: The range to be normalized.
'RepeatingColsCount: The number of columns, starting with the leftmost,
' whose headings remain the same.
'NormalizedColHeader: The column header for the rolled-up category.
'DataColHeader: The column header for the normalized data.
'NewWorkbook: Put the sheet with the data in a new workbook?
'
'NOTE: The data must be in a contiguous range and the
'rows that will be repeated must be to the left,
'with the rows to be normalized to the right.
Sub NormalizeList(List As Excel.Range, RepeatingColsCount As Long, _
NormalizedColHeader As String, DataColHeader As String, _
Optional NewWorkbook As Boolean = False)
Dim FirstNormalizingCol As Long, NormalizingColsCount As Long
Dim ColsToRepeat As Excel.Range, ColsToNormalize As Excel.Range
Dim NormalizedRowsCount As Long
Dim RepeatingList() As String
Dim NormalizedList() As Variant
Dim ListIndex As Long, i As Long, j As Long
Dim wbSource As Excel.Workbook, wbTarget As Excel.Workbook
Dim wsTarget As Excel.Worksheet
With List
'If the normalized list won't fit, you must quit.
If .Rows.Count * (.Columns.Count - RepeatingColsCount) > .Parent.Rows.Count Then
MsgBox "The normalized list will be too many rows.", _
vbExclamation + vbOKOnly, "Sorry"
Exit Sub
End If
'You have the range to be normalized and the count of leftmost rows to be repeated.
'This section uses those arguments to set the two ranges to parse
'and the two corresponding arrays to fill
FirstNormalizingCol = RepeatingColsCount + 1
NormalizingColsCount = .Columns.Count - RepeatingColsCount
Set ColsToRepeat = .Cells(1).Resize(.Rows.Count, RepeatingColsCount)
Set ColsToNormalize = .Cells(1, FirstNormalizingCol).Resize(.Rows.Count, NormalizingColsCount)
NormalizedRowsCount = ColsToNormalize.Columns.Count * .Rows.Count
ReDim RepeatingList(1 To NormalizedRowsCount, 1 To RepeatingColsCount)
ReDim NormalizedList(1 To NormalizedRowsCount, 1 To 2)
End With
'Fill in every i elements of the repeating array with the repeating row labels.
For i = 1 To NormalizedRowsCount Step NormalizingColsCount
ListIndex = ListIndex + 1
For j = 1 To RepeatingColsCount
RepeatingList(i, j) = List.Cells(ListIndex, j).Value2
Next j
Next i
'We stepped over most rows above, so fill in other repeating array elements.
For i = 1 To NormalizedRowsCount
For j = 1 To RepeatingColsCount
If RepeatingList(i, j) = "" Then
RepeatingList(i, j) = RepeatingList(i - 1, j)
End If
Next j
Next i
'Fill in each element of the first dimension of the normalizing array
'with the former column header (which is now another row label) and the data.
With ColsToNormalize
For i = 1 To .Rows.Count
For j = 1 To .Columns.Count
NormalizedList(((i - 1) * NormalizingColsCount) + j, 1) = .Cells(1, j)
NormalizedList(((i - 1) * NormalizingColsCount) + j, 2) = .Cells(i, j)
Next j
Next i
End With
'Put the normal data in the same workbook, or a new one.
If NewWorkbook Then
Set wbTarget = Workbooks.Add
Set wsTarget = wbTarget.Worksheets(1)
Else
Set wbSource = List.Parent.Parent
With wbSource.Worksheets
Set wsTarget = .Add(after:=.Item(.Count))
End With
End If
With wsTarget
'Put the data from the two arrays in the new worksheet.
.Range("A1").Resize(NormalizedRowsCount, RepeatingColsCount) = RepeatingList
.Cells(1, FirstNormalizingCol).Resize(NormalizedRowsCount, 2) = NormalizedList
'At this point there will be repeated header rows, so delete all but one.
.Range("1:" & NormalizingColsCount - 1).EntireRow.Delete
'Add the headers for the new label column and the data column.
.Cells(1, FirstNormalizingCol).Value = NormalizedColHeader
.Cells(1, FirstNormalizingCol + 1).Value = DataColHeader
End With
End Sub
You’d call it like this:
Sub TestIt()
NormalizeList ActiveSheet.UsedRange, 1, "Name", "Count", False
End Sub