I have the Excel data as seen in picture one.
I try to find the text Statetext01 and make 24 copies of it with the right index from 1-24 and I will also change the text in column A from State_text_1 to State_text_24.
After that, I need to find the next one in the Excel sheet and do the same.
The Excel sheet is in over 20000 rows.
Is that possible?
Something like this works for me and should work for you assuming your data is on 'Sheet1':
Option Explicit
Sub copyMultiple()
Dim sht As Worksheet
Dim idx As Integer, lastRow As Integer, r As Integer, r2 As Integer
Dim val As String
Set sht = Worksheets("Sheet1")
With sht
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For r = lastRow To 1 Step -1
val = .Cells(r, "D").Value
idx = InStr(1, val, "Statetext01", vbTextCompare)
If idx <> 0 Then
Rows(r + 1).Resize(23).Insert shift:=xlShiftDown
.Rows(r).Copy Destination:=.Rows(r + 1 & ":" & r + 23)
For r2 = 1 To 24
With .Cells(r + r2 - 1, "D")
.Value = Replace(.Value, "Statetext01", "Statetext" & Right("00" & r2, 2))
End With
With .Cells(r + r2 - 1, "A")
.Value = Left(.Value, InStrRev(.Value, "_")) & "State_text_" & r2
End With
Next
End If
Next
End With
End Sub
Related
I have an Excel sheet where I have different numbers in range A1 to A10. I need to take the value from the cell and add that many rows under that cell.
Lets say A1 as 3 as value and macro should add 2 rows below A1.
I have tried using "Rows" function but I couldn't find a way out.
Please help.
This should get you going. Let me know if you need any further help.
Sub CellsValue()
Dim Colm As Integer
Dim lastrow As Long, deflastrow As Long
'Get the Position of the Required column which has the numbers that it has to shift towards
Colm = WorksheetFunction.Match("Cells Value", Sheets("Sheet1").Rows(1), 0)
'Get the lastrow of that column
lastrow = ActiveSheet.Cells(Rows.Count, Colm).End(xlUp).Row
deflastrow = Application.Sum(Range(Cells(1, Colm), Cells(lastrow, Colm)))
For i = 2 To deflastrow + lastrow
Range("A" & i + 1).Select
InsertRow = Range("A" & i).Value
If InsertRow > 0 Then
InsertRow = InsertRow - 1
End If
If InsertRow = 0 Then
Range("A" & i + 1).Select
Else
For j = 1 To InsertRow
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Next
End If
Next
End Sub
I have made the change. Now it will work. Kindly accept the answer if it works for you.
Alternate solution:
Sub tgr()
Dim ws As Worksheet
Dim i As Long
Const sCol As String = "A"
Set ws = ActiveWorkbook.ActiveSheet
For i = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row - 1 To 1 Step -1
With ws.Cells(i, sCol)
If IsNumeric(.Value) Then
If .Value - 1 > 0 Then .Offset(1).Resize(.Value - 1).EntireRow.Insert xlShiftDown
End If
End With
Next i
End Sub
Dim i, max, num As Integer
i = 1
max = 10
Do While i < max
Range("A" & i).Select
num = Selection.Value
Dim x As Integer
x = 0
Do While x < num
i = i + 1
Range("A" & i).Select
Selection.EntireRow.Insert
max = max + 1
x = x + 1
Loop
i = i + 1
Loop
End Sub
I have done the following 2 VBA code in excel. Main purpose is to combine multiple address rows into a single line. Problem is it takes forever to run. Is there anyway I can optimise it?
The data is as such, there is a case# for each of the customer address. The customer address can be split into multiple rows. Example: "Address row 1 - Block 56", "Address row 2 - Parry Avenue", "address row 3 - Postal code". There is a blank space between each new address.
My purpose is to combine the address into a single line, and remove the empty rows in between the case numbers eg "Block 56 Parry Avenue Postal code". There are approx 26K case numbers.
Sub test()
Dim l As Long
Dim lEnd As Long
Dim wks As Worksheet
Dim temp As String
Application.EnableEvents = False
Application.ScreenUpdating = False
Set wks = Sheets("data")
wks.Activate
lEnd = ActiveSheet.UsedRange.Rows.Count
For l = 3 To lEnd
If Not IsEmpty(Cells(l, 1)) Then
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
Else: Cells(l, 1).EntireRow.Delete
Do Until IsEmpty(Cells(l + 1, 4))
temp = Cells(l, 4).Value & " " & Cells(l + 1, 4).Value
Cells(l, 4).Value = temp
Cells(l + 1, 4).EntireRow.Delete
Loop
End If
Next l
End Sub
and the 2nd code I tried
Sub transformdata()
'
Dim temp As String
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Range("A3").Select
Do Until IsEmpty(ActiveCell) And IsEmpty(ActiveCell.Offset(1, 0))
Do Until IsEmpty(ActiveCell.Offset(1, 3))
temp = ActiveCell.Offset(, 3).Value & " " & ActiveCell.Offset(1, 3).Value
ActiveCell.Offset(, 3).Value = temp
ActiveCell.Offset(1, 3).EntireRow.Delete
Loop
ActiveCell.Offset(1, 0).EntireRow.Delete
ActiveCell.Offset(1, 0).Select
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Change the line lEnd = ActiveSheet.UsedRange.Rows.Count. Incorrect way of finding last row. You may want to see This
To delete rows where Cells(l, 1) is empty, use Autofilter. See This
Do not delete rows in a straight loop. Use a reverse loop. Or what you could do is identify the cells that you want to delete in a loop and then delete them in one go after the loop. You may want to see This
Here is a basic example.
Let's say your worksheet looks like this
If you run this code
Sub test()
Dim wks As Worksheet
Dim lRow As Long, i As Long
Dim temp As String
Application.ScreenUpdating = False
Set wks = Sheets("data")
With wks
'~~> Find Last Row
lRow = .Range("C" & .Rows.Count).End(xlUp).Row
For i = lRow To 2 Step -1
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
If temp = "" Then
temp = .Range("C" & i).Value
Else
temp = .Range("C" & i).Value & "," & temp
End If
Else
.Range("D" & i + 1).Value = temp
temp = ""
End If
Next i
End With
End Sub
You will get this output
Now simply run the autofilter to delete the rows where Col D is empty :) I have already give you the link above for the same.
The code below will copy all the data into an array, consolidate it, and add it to a new worksheet. You'll need to make COLUMNCOUNT = the number of columns that contain data.
Sub TransformData2()
Const COLUMNCOUNT = 4
Dim SourceData, NewData
Dim count As Long, x1 As Long, x2 As Long, y As Long
SourceData = Range("A" & Range("D" & Rows.count).End(xlUp).Row, Cells(3, COLUMNCOUNT))
For x1 = 1 To UBound(SourceData, 1)
count = count + 1
If count = 1 Then
ReDim NewData(1 To 4, 1 To count)
Else
ReDim Preserve NewData(1 To 4, 1 To count)
End If
For y = 1 To UBound(SourceData, 2)
NewData(y, count) = SourceData(x1, y)
Next
x2 = x1 + 1
Do
NewData(4, count) = NewData(4, count) & " " & SourceData(x2, 4)
x2 = x2 + 1
If x2 > UBound(SourceData, 1) Then Exit Do
Loop Until IsEmpty(SourceData(x2, 4))
x1 = x2
Next
ThisWorkbook.Worksheets.Add
Range("A1").Resize(UBound(NewData, 2), UBound(NewData, 1)).Value = WorksheetFunction.Transpose(NewData)
End Sub
I want to copy data from one sheet to another with few conditions:
1. Start with row 1 and column 1 and match if the R1 C2 is not empty then copy the pair R1 C1 and R1 C2 and paste into the other sheet as a new row.
increment the counter for column and match R1 C1 with R1 C3 and so on.
increment the Row when the column counter reaches 10.
I tried the below code but gives compile error as Sub or function not defined.
Please help.
Private Sub CommandButton1_Click()
Dim x As Integer
Dim y As Integer
x = 2
y = 2
Do While Cells(x, 1) <> ""
If Cells(x, y) <> "" Then
Worksheets("Sheet1").Cells(x, 2).Copy
Worksheets("Sheet2").Activate
erow = Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
ActiveSheet.Paste Destination:=Worksheets("Sheet2").Rows(erow)
End If
Worksheets("Sheet1").Activate
y = y + 1
If y = 10 Then x = x + 1
End If
Loop
End Sub
You are geting that error because of > in Sheet2.Cells(Rows.Count, 1).End(xlUp) > Offset(1, 0).Row
Avoid the use of using Integer when you are working with rows. Post excel2007, the row count has increased and the Integer may not be able to handle the row number.
Avoid the use of .Activate.
Is this what you are trying? (Untested)
Note: I am demonstrating and hence I am working with the excel cells directly. But in reality, I would be using autofilter & arrays to perform this operation.
Private Sub CommandButton1_Click()
Dim wsInput As Worksheet, wsOutput As Worksheet
Dim lRowInput As Long, lRowOutput As Long
Dim i As Long, j As Long
Set wsInput = ThisWorkbook.Worksheets("Sheet1")
Set wsOutput = ThisWorkbook.Worksheets("Sheet2")
With wsInput
lRowInput = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRowInput
If .Cells(i, 2).Value <> "" Then
For j = 3 To 10
lRowOutput = wsOutput.Range("A" & wsOutput.Rows.Count).End(xlUp).Row + 1
.Range(.Range(.Cells(i, 1), .Cells(i, 1)).Address & _
"," & _
.Range(.Cells(i, j), .Cells(i, j)).Address).Copy _
wsOutput.Range("A" & lRowOutput)
Next j
End If
Next i
End With
End Sub
I need to compare 1 worksheet (Sheet1) to another similar worksheet (Sheet2)
Sheet2 contains up to date information,which needs to be transferred to Sheet1.
However, I've run into a couple of problems:
There are some rows in Sheet1 that are not Sheet2. These need to be ignored/skipped over
There are some rows in Sheet2 that are not Sheet1. These need to be appended to the end of Sheet1
If a row exists in both Sheets, the information from the row sheet 2 needs to be transferred to the corresponding row in Sheet1
For what its worth, they have same number of columns and the column titles are exactly the same.
I've tried using a dictionary object to accomplish this but am still having all sorts of trouble.
Here's the code I have tried thus far:
Sub createDictionary()
Dim dict1, dict2 As Object
Set dict1 = CreateObject("Scripting.Dictionary")
Set dict2 = CreateObject("Scripting.Dictionary")
Dim maxRows1, maxRows2 As Long
Dim i, ii, j, k As Integer
maxRows1 = Worksheets("Sheet1").Range("A65000").End(xlUp).Row
For i = 2 To maxRows1
Dim cell1 As String
cell1 = Worksheets("Sheet1").cells(i, 2).Text & " " & Worksheets("Sheet1").cells(i, 11).Text
If Not dict1.Exists(cell1) Then
dict1.Add cell1, cell1
End If
Next i
maxRows2 = Worksheets("Sheet2").Range("A65000").End(xlUp).Row
For ii = 2 To maxRows2
Dim cell2 As String
cell2 = Worksheets("Sheet2").cells(ii, 11).Text
If Not dict2.Exists(cell2) Then
dict2.Add cell2, cell2
End If
Next ii
Dim rngSearch1, rngFound1, rngSearch2, rngFound2 As Range
For j = 2 To maxRows1
Dim Sheet1Str, Sheet2Str As String
Sheet1Str = Worksheets("Sheet1").cells(j, 2).Text & " " & Worksheets("Sheet1").cells(j, 11).Text
Sheet2Str = Worksheets("Sheet2").cells(j, 11).Text
If dict2.Exists(Sheet1Str) = False Then
'ElseIf Not dict1.Exists(Sheet2) Then
'
' Worksheets("Sheet2").Range("A" & j & ":" & "Z" & j).Copy
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Insert
' Worksheets("Sheet1").Range("A" & maxRows1 + 1).Interior.Color = RGB(255, 255, 0)
' Worksheets("Sheet1").Range("U" & maxRows1 + 1) = "INCH"
' Worksheets("Sheet1").Range("Q" & maxRows1 + 1) = "FPM"
' Worksheets("Sheet1").Range("S" & maxRows1 + 1) = "INCHES WIDE"
' Worksheets("Sheet2").Range("K" & j) = Replace(Worksheets("Sheet2").Range("K" & j), Worksheets("Sheet2").Range("B" & j), "")
' Worksheets("Sheet1").Range("K" & maxRows1 + 1) = Trim(Worksheets("Sheet2").Range("K" & j))
Else
For k = 3 To 6
If Not k = 11 Then
If Not UCase(Worksheets("Sheet1").cells(j, k).Value) = UCase(Worksheets("Sheet2").cells(j, k).Value) Then
Worksheets("Sheet1").cells(j, k).Value = Worksheets("Sheet2").cells(j, k).Value
End If
End If
Next k
End If
Next j
End Sub
Cool question, and the "does row order matter" question above lends itself nicely to using Excel's built in Range.RemoveDuplicates method. Let's get into it...
Suppose Sheet1 looks like this:
Let's say Sheet2 looks like this:
All the conditions that are described in your original question are met here. Namely:
There are rows on Sheet1 that are not on Sheet2 (row 2, for example). These will be left alone.
There are rows on Sheet2 that are not on Sheet1 (row 2, for example). These will be added to Sheet1.
There are rows that are the same on Sheet2 and Sheet1, save for a single update. (Row 7 on Sheet2, for example.) These rows will be updated on Sheet1. Of course, your situation will be different -- perhaps more columns might be updated, or they might not be in column E like my example -- you'll need to do a bit of customization here.
The following heavily-commented script walks through copying data from Sheet2 to Sheet1, then letting Excel's built-in Range.RemoveDuplicates method kill all of the rows that have been updated in column E. The script also makes use of a couple handy functions: LastRowNum and LastColNum.
Option Explicit
Sub MergeSheetTwoIntoSheetOne()
Dim Range1 As Range, Range2 As Range
Dim LastRow1 As Long, LastRow2 As Long, _
LastCol As Long
'setup - set references up-front
LastRow2 = LastRowNum(Sheet2)
LastRow1 = LastRowNum(Sheet1)
LastCol = LastColNum(Sheet1) '<~ last col the same on both sheets
'setup - identify the data block on sheet 2
With Sheet2
Set Range2 = .Range(.Cells(2, 1), .Cells(LastRow2, LastCol))
End With
'setup - identify the data block on sheet 1
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
End With
'step 1 - move the data block on sheet 1 down the sheet
' to allow room for the data block from sheet 2
Range1.Cut Destination:=Sheet1.Cells(LastRow2 + 1, 1)
'step 2 - move the data block from sheet 2 into the recently-
' cleared space on sheet 1
Range2.Copy Destination:=Sheet1.Cells(2, 1)
'step 3 - find the NEW last row on sheet 1
LastRow1 = LastRowNum(Sheet1)
'step 4 - use excel's built-in duplicate removal to
' kill all dupes on every column EXCEPT for those
' that might have been updated on sheet 2...
' in this example, Column E is where updates take place
With Sheet1
Set Range1 = .Range(.Cells(2, 1), .Cells(LastRow1, LastCol))
Range1.RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlYes
End With
End Sub
'this handy function allows us to find the last row with a one-liner
Public Function LastRowNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastRowNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
Else
LastRowNum = 1
End If
End Function
'this handy function allows us to find the last column with a one-liner
Public Function LastColNum(Sheet As Worksheet) As Long
If Application.WorksheetFunction.CountA(Sheet.Cells) <> 0 Then
LastColNum = Sheet.Cells.Find(What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Else
LastColNum = 1
End If
End Function
Running this script results in the following:
I have an excel with two columns (B & C) - Business case and solution, there will be multiple business cases which might have same solution, i want to merge it based on solution. Something like below -
BC1 Sol1
BC2 Sol2
BC3 Sol2
BC4 Sol3
BC5 Sol4
BC6 Sol4
BC7 Sol4
output should be -
BC1 Sol1
BC2, BC3 Sol2
BC4 Sol3
BC5, BC6, BC7 Sol4
i would like to do this in VBA and tried something like below -
LASTROW = Range("C" & Rows.Count).End(xlUp).Row 'get last row
For I = 0 To LASTROW Step 1
For J = I + 1 To LASTROW Step 1
If Cells(I, "C") = Cells(J, "C") Then
Cells(I, "B") = Cells(I, "B") & "," & Cells(J, "B")
Rows(J).Delete
End If
Next
Next
the above works, but is very slow when running on 1000 rows, i went through other questions similar to this but not good in VBA to mod that for above one. Can someone please help ?
As you have commented, using a variant array rather than looping the cells directly will speed this up enormously
To apply that here you could:
Determine the source data range, and copy that into an array
Create another array to contain the new data
Loop the source array, testing for the required patterns, and populate the destination array
Copy the new data back to the sheet, overwriting the old data
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim datSrc As Variant
Dim datDst As Variant
Dim i As Long
Dim j As Long
Dim rwOut As Long
Dim str As String
Set ws = ActiveSheet
With ws
Set rng = Range(.Cells(1, 2), .Cells(.Rows.Count, 3).End(xlUp))
datSrc = rng.Value
ReDim datDst(1 To UBound(datSrc, 1), 1 To UBound(datSrc, 2))
rwOut = 1
For i = 1 To UBound(datSrc, 1)
str = datSrc(i, 1)
If datSrc(i, 2) <> vbNullString Then
For j = i + 1 To UBound(datSrc, 1)
If datSrc(i, 2) = datSrc(j, 2) Then
str = str & "," & datSrc(j, 1)
datSrc(j, 2) = vbNullString
End If
Next
datDst(rwOut, 1) = str
datDst(rwOut, 2) = datSrc(i, 2)
rwOut = rwOut + 1
End If
Next
rng = datDst
End With
End Sub