I need a loop that will match and select different columns (not in sequential order) and paste them to another sheet all whilst keeping the condition in check. It would also be ideal if when the values get pasted that the formatting for the cell is not carried over, just the value.
Below is the code I am currently using:
Sub Test()
Application.ScreenUpdating = False
Sheets("DATA").Select
lr = Range("B" & Rows.Count).End(xlUp).Row
Range("P3").Select
For i = 3 To lr
If Cells(i, 2) <> "" Then Range(Cells(i, 7), Cells(i, 16), Cells(i, 26)).Copy
Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Next
Application.ScreenUpdating = True
End Sub
The problem is declaring the columns I want the loop to paste. I need the loop to run through the 16th column, check empty values, and then paste the index/matched value in the rows of columns 7,16,and 26 (so not in sequential order).. Any help would be appreciated.
The next code has to do what I understood you need. Please check it and confirm this aspect. It is very fast, working only in memory...
Sub PastingNextPage()
Dim sh As Worksheet, sh1 As Worksheet, arrIn As Variant, arrOut() As Variant
Dim lastRowIn As Long, lastRowOut As Long, nonEmpt As Long, rngP As Range, nrEl As Long
Dim i As Long, j As Long, P As Long
Set sh = Sheets("DATA"): lastRowIn = sh.Range("P" & sh.Rows.count).End(xlUp).Row
Set sh1 = Sheets("Sheet2"): lastRowOut = sh1.Range("A" & sh1.Rows.count).End(xlUp).Row + 1
arrIn = sh.Range("G2:Z" & lastRowIn).Value
nrEl = lastRowIn - Application.WorksheetFunction.CountIf(sh.Range("P2:P" & lastRowIn), "") - 2
P = 10 'column P:P number in the range starting with G:G column
ReDim arrOut(nrEl, 3) 'redim the array to keep the collected values
For i = 1 To lastRowIn - 1
If arrIn(i, P) <> "" Then
arrOut(j, 0) = arrIn(i, 1): arrOut(j, 1) = arrIn(i, P): arrOut(j, 2) = arrIn(i, 20)
j = j + 1
End If
Next i
sh1.Range(sh1.Cells(lastRowOut, "A"), sh1.Cells(lastRowOut + nrEl, "C")).Value = arrOut
End Sub
It does not select anything, you can run it activating any of the two involved sheets. I would recommend to be in "Sheet2" and see the result. If you want to repeat the test, its result will be added after the previous testing resulted rows...
If something unclear or not doing what you need, do not hesitate to ask for clarifications.
Related
I'm writing a code to loop through an excel sheet and changing the text (in column B) to uppercase/lowercase, depending on the value of cell in column N on the same row.
Macros purpose:
loop through cells in column B starting at row 2 and changing the string from upper to lowercase or vice versa, depending on the value of the cell in column N (lowercase if value = 5, other cases text should be uppercase)
Code I've got so far:
Sub CAPS()
'
' CAPS Macro
'
Dim Rang As Integer
Dim j As Integer
j = 2
For Each N In Source.Range("N2:N10000") ' Do 10000 rows
Rang = Cells(j, 14)
If Rang = 5 Then
Cells(j, 2).Range("A1").Select
ActiveCell.Value = LCase$(ActiveCell.Text)
Else
ActiveCell.Value = UCase$(ActiveCell.Text)
j = j + 1
End If
Next N
End Sub
I'm a little bit stuck in the looping part, not really a clue how to fix the error(s) in the current code.
Thanks in advance :)
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
For N Is 2 to 10000 ' Do 10000 rows
If Cells(N, 14) = 5 Then
Cells(N, 2) = LCase(Cells(N,2)
Else
Cells(N, 2) = UCase(Cells(N,2)
EndIf
Next N
End Sub
This should do the trick, untested though.
You currently have a fixed number of rows you want to test. To optimize your code you could first check how many rows are filled with data. To do so you can use:
DIM lastrow as long
lastrow = Cells(Rows.Count, "B").End(xlUp).Row
And then make the loop with For N Is 2 to lastrow
Also it is good practice to explicitly reference your worksheets, as this prevents undesired results. For example you click on another worksheet whilst the code is running it will continue formatting on that sheet. To do so declare a variable as your worksheet:
DIM ws as worksheet
And set a value to your variable, in this case Sheet1.
Set ws as ThisWorkbook.Worksheets("Sheet1")
Now every time you reference a Cells(), you explicitly say on what sheet that has to be by adding ws. in front of it like such: ws.Cells()
To summarize all that into your code:
Sub CAPS()
'
' CAPS Macro
'
Dim N as long 'use long here as integer is limite to a 32b character
Dim lastrow as long
Dim ws as worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'Set the code to run on Sheet 1 of your current workbook.
lastrow = ws.Cells(Rows.Count, "B").End(xlUp).Row
For N Is 2 to lastrow ' Do all rows that have data in column B
If ws.Cells(N, 14) = 5 Then
ws.Cells(N, 2) = LCase(ws.Cells(N,2)
Else
ws.Cells(N, 2) = UCase(ws.Cells(N,2)
EndIf
Next N
End Sub
Try processing in an array,
Sub CAPS()
'
' CAPS Macro
'
Dim arr As variant, j As Integer
with worksheets("sheet1")
arr = .range(.cells(2, "B"), .cells(.rows.count, "B").end(xlup).offset(0, 12)).value2
for j= lbound(arr, 1) to ubound(arr, 1)
if arr(j, 13) = 5 then
arr(j, 1) = lcase(arr(j, 1))
else
arr(j, 1) = ucase(arr(j, 1))
end if
next j
redim preserve arr(lbound(arr, 1) to ubound(arr, 1), 1 to 1)
.cells(2, "B").resize(ubound(arr, 1), ubound(arr, 2)) = arr
end with
End Sub
You may try something like this...
Sub CAPS()
Dim ws As Worksheet
Dim lr As Long, i As Long
Application.ScreenUpdating = False
Set ws = Sheets("Sheet1") 'Sheet where you have to change the letter case
lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To lr
Select Case ws.Cells(i, "N")
Case 5
ws.Cells(i, "B") = LCase(ws.Cells(i, "B"))
Case Else
ws.Cells(i, "B") = UCase(ws.Cells(i, "B"))
End Select
Next i
Application.ScreenUpdating = True
End Sub
Another approach using for each loop with Range:
Sub UCaseLCase()
Dim rng, cell As Range
Dim Test As Integer
Test = 5
Set rng = Range(Cells(2, 14), Cells(10000, 14))
For Each cell In rng.Cells
If cell.Value = Test Then
cell.Offset(0, -12) = LCase(cell.Offset(0, -12))
Else
cell.Offset(0, -12) = UCase(cell.Offset(0, -12))
End If
Next cell
End Sub
I know you said in your question starting at row 2 but it's easier just going from last row until row 2.
Hope this can help or at least, learn something new about Loops :)
Sub CAPS()
Dim j As Integer
For j = Range("B2").End(xlDown).Row To 2 Step -1
If Range("N" & j).Value = 5 Then
'uppercase
Range("B" & j).Value = UCase(Range("B" & j).Value)
Else
'lowercase
Range("B" & j).Value = LCase(Range("B" & j).Value)
End If
Next j
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
I have 3 issues with the following piece of code:
Intention of code: I have a table of data, 4 columns (F,G, H and I) wide and X rows long (X is typically between 5 and 400). I have a list of dates in column M, typically no more than 8 dates. Column H of table, contains dates as well. I want to find the dates that are in both columns (H and M) and whenever they appear, go to the same row in column I and set its value to zero, and the one after it (so if a match was in H100, then I100 and I101 would be zeroed).
issues with code: edited 1) as per feedback.
1) I have, using an if formula (=if(H100=M12,1,0), verified that there is one match, as how the spreadsheet sees it. The macro does not find this match, despite confirmation from the if formula. Cells I100 and I101 have nonzero values, when they should be zeroed.
2) the code runs, but takes about 3 minutes to go through 3 sheets of 180 rows of data. What can be done to make it run faster and more efficiently? It could have up to 30 sheets of data, and 400 rows (extreme example but possible, in this instance im happy to let it run a bit).
3) Assuming my data table before the macro is run, is 100 rows long, starting in row 12, after the macro, column I has nonzero values for 111 rows, and zeroes for the next 389. Is there a way I can prevent it from filling down zeroes, and leaving it blank?
I am using a correlate function afterwards on column I and there huge agreement of 0's with 0's is distorting this significantly. Thanks in advance,
Sub DeleteCells()
Dim ws As Worksheet
Dim cell As Range, search_cell As Range
Dim i As Long
Dim h As Long
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then
For Each cell In ws.Range("H12:H500")
On Error Resume Next
h = ws.Range("G" & Rows.Count).End(xlUp).Row
i = ws.Range("L" & Rows.Count).End(xlUp).Row
Set search_cell = ws.Range("M12:M" & h).Find(what:=cell.Value, LookIn:=xlValues, lookat:=xlWhole)
On Error GoTo 0
If Not search_cell Is Nothing Then
ws.Range("I" & cell.Row).Value = 0
ws.Range("I" & cell.Row + 1).Value = 0
Set search_cell = Nothing
End If
Next cell
End If
Next ws
Application.ScreenUpdating = True
Set ws = Nothing: Set cell = Nothing: Set search_cell = Nothing
End Sub
EDIT: TESTED CODE, will work for 0, 1 row of data in H/M column starting from row 12?
EDIT: Updated the cell to handle case with 1 line of data, untested :|
I will give my solution first, this one should be much faster because it read the cells into memory first
Please comment if it doesn't work or you have further question
Sub DeleteCells()
Dim ws As Worksheet
Dim i As Long
Dim h As Long
Dim MColumn As Variant ' for convinence
Dim HColumn As Variant
Dim IColumn As Variant
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name = "Cover" Then 'matching the target sheet
' matching the rows where column M's date matches column H's date
'starting row num is 12
With ws ' for simplifying the code
h = .Range("H" & .Rows.count).End(xlUp).Row
If h = 12 Then ' CASE for 1 row only
If Range("H12").Value = Range("M12").Value Then
Range("I12:I13").Value = ""
End If
ElseIf h < 12 Then
' do nothing
Else
ReDim HColumn(1 To h - 11, 1 To 1)
ReDim MColumn(1 To h - 11, 1 To 1)
ReDim IColumn(1 To h - 10, 1 To 1)
' copying the data from worksheet into 2D arrays
HColumn = .Range("H12:H" & h).Value
MColumn = .Range("M12:M" & h).Value
IColumn = .Range("I12:I" & h + 1).Value
For i = LBound(HColumn, 1) To UBound(HColumn, 1)
If Not IsEmpty(HColumn(i, 1)) And Not IsEmpty(MColumn(i, 1)) Then
If HColumn(i, 1) = MColumn(i, 1) Then
IColumn(i, 1) = ""
IColumn(i + 1, 1) = ""
End If
End If
Next i
'assigning back to worksheet cells
.Range("H12:H" & h).Value = HColumn
.Range("M12:M" & h).Value = MColumn
.Range("I12:I" & h + 1).Value = IColumn
End If
End With
End If
Next ws
Application.ScreenUpdating = True
End Sub