My code :
For i = 1 To iRowNumber
If Cells(i, x).Value > 1 Then
Cells(i, 2).Copy
Sheets(1).Select
Cells(1, 1).Value = Now
Cells(1, 2).Value = "Duplicate"
Cells(1, 4).Select
ActiveSheet.Paste
Cells(1, 3).Value = Mid(Cells(1, 4), 5, 4)
End If
Next i
x=x+1
Condition :
sheet(2) > 130916001, 130916001000009, 1 '~> check if 3rd column more than 1
expected result :
sheet(1) first row > time , "duplicate", 1600 , 130916001000009
sheet(2) 130916001, 130916001000009, 2 '~> change 1 become 2
result :
sheet(1) fine
sheet(2) 130916001, 130916001000009, not2 '~> error
If i extract this part of code, the counter works fine
Fyi i have 6 sheets, but dunno because of this or not?
Keeping #nutsch suggestions in mind, here is some code with qualified cells, so there's no confusion about which cells belong to which sheet. I'm not exactly sure what you're trying to accomplish, but should be easy enough to make appropriate changes.
Sub copyData()
Dim i As Long, x As Long, iRowNumber As Long
For i = 1 To iRowNumber
If Sheet2.Cells(i, 3) = 1 Then
With Sheet1
.Cells(i, 1).Value = Now() 'time
.Cells(i, 2).Value = "Duplicate"
.Cells(i, 3).Value = Mid(Sheet2.Cells(i, 2), 5, 4)
.Cells(i, 4).Value = Sheet2.Cells(i, 2).Value
End With
Sheet2.Cells(i, 3).Value = 2
End If
Next i
End Sub
Related
I'm new to VBA so this is probably a very obvious mistake.
To keep it short, I am trying to delete rows based on two criteria: In Column A, if they have the same value (duplicate) and in Column B, the difference is less than 100, then one row is deleted from the bottom.
Example data:
Column A Column B
1 300
1 350 SHOULD be deleted as second column diff. is <100 compared to row above
2 500
2 700 Should NOT be deleted as second column diff. is not <100
Here is the code I have come up with:
Sub deduplication()
Dim i As Long
Dim j As Long
Dim lrow As Long
Application.ScreenUpdating = False
With Worksheets("Sheet1")
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = lrow To 2 Step -1
For j = i To 2 Step -1
If .Cells(i, "A").Value = .Cells(j, "A").Value And .Cells(i, "B").Value - .Cells(j, "B").Value < 100 Then
.Cells(i, "A").EntireRow.Delete
End If
Next j
Next i
End With
End Sub
This largely works, but only if the second criterion is greater than (>) rather than less than (<). When it is less than, it deletes every row. What am I doing wrong? Is there an easy fix?
Thank you
Not
If .Cells(i, "A").Value = .Cells(j, "A").Value And .Cells(i, "B").Value - .Cells(j, "B").Value < 100 Then
Here in the second part of the statement, you're just comparing .Cells(j, "B").Value to const 100 !
But
If .Cells(i, "A").Value = .Cells(j, "A").Value And Abs(.Cells(i, "B").Value - .Cells(j, "B").Value) < 100 Then
Abs() may help, else keep just the ( )
Something like this should work for you:
Sub tgr()
Dim ws As Worksheet
Dim rDel As Range
Dim rData As Range
Dim ACell As Range
Dim hUnq As Object
Set ws = ActiveWorkbook.Sheets("Sheet1")
Set hUnq = CreateObject("Scripting.Dictionary")
Set rData = ws.Range("A2", ws.Cells(ws.Rows.Count, "A").End(xlUp))
If rData.Row = 1 Then Exit Sub 'No data
For Each ACell In rData.Cells
If Not hUnq.Exists(ACell.Value) Then
'New Unique ACell value
hUnq.Add ACell.Value, ACell.Value
Else
'Duplicate ACell value
If Abs(ws.Cells(ACell.Row, "B").Value - ws.Cells(ACell.Row - 1, "B").Value) < 100 Then
If rDel Is Nothing Then Set rDel = ACell Else Set rDel = Union(rDel, ACell)
End If
End If
Next ACell
If Not rDel Is Nothing Then rDel.EntireRow.Delete
End Sub
Sticking to the format of your code, you can do this using one For loop as well.
For i = lrow To 3 Step -1
If .Cells(i, "A") = .Cells(i - 1, "A") And (.Cells(i, "B") - .Cells(i - 1, "B")) < 100 Then
.Cells(i, "A").EntireRow.Delete
End If
Next i
Every first j-cycle starts off by comparing a row to itself since you start with j = i. The difference between a value and itself is always zero. (It also compares row 2 with itself as the very last step.)
However, if you switch:
For i = lrow To 2 Step -1
For j = i To 2 Step -1
to:
For i = lrow To 3 Step -1
For j = i - 1 To 2 Step -1`
the code will compare all the various rows without the self-compares.
Another point (which #Proger_Cbsk 's answer brought to mind), is that doing the comparison with just the subtraction .Cells(i, "B").Value - .Cells(j, "B").Value < 100 will sometimes cause unexpected results.
For example, assume .Cells(i, "B").Value = 1 and .Cells(j, "B").Value = 250. We can tell by just looking, that there is a difference of at least 100, so you would expect this part of the expression to evaluate to False. However, from straight substitution, you get the expression: 1 - 250 < 100. Since 1 - 250 = -249, and since -249 < 100, the expression would actually evaluate to True.
However, if you were to change .Cells(i, "B").Value - .Cells(j, "B").Value < 100 to Abs(.Cells(i, "B").Value - .Cells(j, "B").Value) < 100, the expression will now be looking at if the difference is greater or less than 100, instead of looking at if the subtraction result is greater or less than 100.
Why not to use the built-in command:
Worksheets("Sheet1").Range("$A:$A").RemoveDuplicates Columns:=1, Header:=xlYes
Range.RemoveDuplicates Method (Excel)
The macro below opens a series of workbooks from a list, then copies some data from them. It works fine for the first workbook, then crashes on the second. I've tried changing the order, and it's always the second workbook that causes it to crash.
Sub ImportData()
Dim lastRow As Long
Dim lastSumRow As Long
Dim j As Long
Dim k As Long
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
For k = 2 To lastRow
k = 2
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
If ActiveSheet.Cells(k, 2).Value <> "Imported" Then
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
ActiveWorkbook.Sheets("Summary").Activate
For j = 3 To 100
If j Mod 3 = 0 Then
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ActiveWorkbook.Sheets("Summary").Cells(j, 1).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 4).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 5).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 2).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 6).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 3).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 7).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 2, 4).Value
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 8).Value = ActiveWorkbook.Sheets("Summary").Cells(j + 1, 5).Value
End If
Next j
ActiveWorkbook.Close
End If
ThisWorkbook.Sheets("Setup").Cells(k, 2).Value = "Imported"
Next k
End Sub
I'm guessing your error is here:
Workbooks.Open Filename:=ThisWorkbook.Path & "\Analysis\" & Cells(k, 1), UpdateLinks:=False
'Ooops ^^^^^
The .Activate and .Select calls are convoluted enough that I'm not really going to expend the effort figuring out what should be the active worksheet at that particular point in your code on the second run through the loop. Whatever it is, it's different than it was when you started and an unqualified call to Cells implicitly refers to whatever worksheet is the ActiveSheet at the time. This builds a bad file name (or fails completely) and then the wheels come off.
The best thing to do is not use the Active* objects at all. Get references to the objects that you're using, and well, use them. That way there is no chance that you'll get wires crossed. While you're at it, you can give them names that make it obvious what you're working with at a glance.
Couple other things before we get to the code that doesn't use Activate and Select.
lastSumRow is never used and lastUsedRow is never declared. I'm assuming they were supposed to be the same thing. You should put Option Explicit at the top of your modules to avoid this type of error (and worse ones).
These 2 lines of code make very little sense together:
For j = 3 To 100
If j Mod 3 = 0 Then
If you only want to copy every 3rd row, skip all the division and just increment your loop counter with a Step of 3:
For j = 3 To 99 Step 3
Note that you can stop at 99, because 100 Mod 3 is never going to be 0.
Your With block here isn't using the captured reference...
With ActiveSheet
lastRow = ActiveSheet.Cells(1048576, 1).End(xlUp).Row
End With
...but you continually use this pattern that would be useful in a With block:
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 1).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 2).Value = ...
ThisWorkbook.Sheets("Summary").Cells((j / 3) + lastUsedRow, 3).Value = ...
Hard-coding Cells(1048576, 1) will fail on older versions of Excel. You should use Rows.Count instead.
As mentioned in the comments, k = 2 creates an infinite loop.
You don't need to repeatedly find the last row of the sheet you're copying to with this code:
lastUsedRow = ThisWorkbook.Sheets("Summary").Cells(1048576, 1).End(xlUp).Row
Each time you go through your "j" loop, the last row increases by one. Just add 1 to lastUsedRow instead of doing all the row counting gymnastics.
If you're working with Worksheets, use the Worksheets collection instead of the Sheets collection:
ThisWorkbook.Sheets("Summary") '<--I could return a Chart!
Put all of that together, and you come up with something like the code below. Note that I have no clue what the ActiveSheet is supposed to be when you start this macro, so I just named the variable it's stored in active. It's quite possible that it's one of the other worksheets it grabs a reference too (I have no clue) - if so, you should consolidate them into one reference:
Public Sub ImportData()
Dim lastRow As Long
Dim lastUsedRow As Long
Dim dataRow As Long
Dim fileNameRow As Long
Dim active As Worksheet
Set active = ActiveSheet
With active
lastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
Dim setupSheet As Worksheet
Set setupSheet = ThisWorkbook.Worksheets("Setup")
With ThisWorkbook.Worksheets("Summary")
lastUsedRow = .Cells(.Rows.Count, 1).End(xlUp).Row
For fileNameRow = 2 To lastRow
If active.Cells(fileNameRow, 2).Value <> "Imported" Then
Dim source As Workbook
Set source = Workbooks.Open(ThisWorkbook.Path & "\Analysis\" & _
active.Cells(fileNameRow, 1), False)
Dim dataSheet As Worksheet
Set dataSheet = source.Worksheets("Summary")
For dataRow = 3 To 99 Step 3
.Cells(lastUsedRow, 1).Value = dataSheet.Cells(dataRow, 1).Value
.Cells(lastUsedRow, 2).Value = dataSheet.Cells(dataRow + 1, 2).Value
.Cells(lastUsedRow, 3).Value = dataSheet.Cells(dataRow + 1, 3).Value
.Cells(lastUsedRow, 4).Value = dataSheet.Cells(dataRow + 1, 4).Value
.Cells(lastUsedRow, 5).Value = dataSheet.Cells(dataRow + 2, 2).Value
.Cells(lastUsedRow, 6).Value = dataSheet.Cells(dataRow + 2, 3).Value
.Cells(lastUsedRow, 7).Value = dataSheet.Cells(dataRow + 2, 4).Value
.Cells(lastUsedRow, 8).Value = dataSheet.Cells(dataRow + 1, 5).Value
lastUsedRow = lastUsedRow + 1
Next
source.Close
End If
setupSheet.Cells(fileNameRow, 2).Value = "Imported"
Next
End With
End Sub
I'm currently diving into code/VBA coding for the first time. I have a file that I dump into a worksheet that currently I'm manually organizing and pushing out. When put into the worksheet, it delimits itself across the cells. The first 2-4 cells are always parts of a name. This dump file will have varying row and column lengths every time I get it in a given day and dump into a work sheet. For example, one day it may be twenty rows and one day it may be thirty.
This is a rough illustration of what the data looks like, but my code probably doesn't match with the example below - I just wanted to provide a visual:
So, I'm wanting to make code that will start at A1 and concatenate the cells following it until it runs into a blank cell in that row. Then it places the concatenated data into cell A1 and removes the values it pulled the name pieces from and slides all the data to the left. After that, it continues the same operation on the next row until it meets the final row. As you can see in the image, I don't want any of the data after the blank cell to be affected.
This is my first time programming in general, so when you provide assistance, would you please explain your code so I can learn the concepts? Here's what I think will work so far... I'm just stuck on how to go about concatenating.
The code I currently have:
Sub DN_ERROR_ORGANIZER()
Dim row As Integer
NumRows = Range("A1", Range("A1").End(xldown)).Rows.Count
Range("A1").Select
For row = 1 To NumRows
Do Until IsEmpty(ActiveCell)
' Code to concatenate
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(1, 0).Select
Next
End sub
Here's another way to look at your problem: Suppose you have your table on Sheet2, and the result is reflected on Sheet1.
Sub PutInOrder()
filledcells = 0
'''lastrow = Sheet2.Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 100
If Sheet2.Cells(i, 1) = "" Then Exit For
For a = 1 To 4
If Sheet2.Cells(i, a) = "" Then Exit For
If Sheet2.Cells(i, a) <> "" Then
filledcells = filledcells + 1
End If
Next
Select Case filledcells
Case Is = 2
Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2)
Sheet1.Cells(i, 3) = Sheet2.Cells(i, 4)
Sheet1.Cells(i, 4) = Sheet2.Cells(i, 5)
Sheet1.Cells(i, 5) = Sheet2.Cells(i, 6)
Sheet1.Cells(i, 6) = Sheet2.Cells(i, 7)
Case Is = 3
Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2) + " " + Sheet2.Cells(i, 3)
Sheet1.Cells(i, 3) = Sheet2.Cells(i, 5)
Sheet1.Cells(i, 4) = Sheet2.Cells(i, 6)
Sheet1.Cells(i, 5) = Sheet2.Cells(i, 7)
Sheet1.Cells(i, 6) = Sheet2.Cells(i, 8)
Case Is = 4
Sheet1.Cells(i, 1) = Sheet2.Cells(i, 1) + ", " + Sheet2.Cells(i, 2) + " " + Sheet2.Cells(i, 3) + " " + Sheet2.Cells(i, 4)
Sheet1.Cells(i, 3) = Sheet2.Cells(i, 6)
Sheet1.Cells(i, 4) = Sheet2.Cells(i, 7)
Sheet1.Cells(i, 5) = Sheet2.Cells(i, 8)
Sheet1.Cells(i, 6) = Sheet2.Cells(i, 9)
End Select
filledcells = 0
Next
End Sub
Can you try this and let me know how you get on? It may need some tweaks depending on your precise layout. My approach is slightly different.
Sub x()
Dim n As Long, r1 As Range, r2 As Range, v
For n = 1 To Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next
Set r1 = Cells(n, 1).EntireRow.SpecialCells(xlCellTypeConstants).Areas(1)
Set r2 = Cells(n, 1).EntireRow.SpecialCells(xlCellTypeConstants).Areas(2)
If Not r1 Is Nothing And Not r2 Is Nothing Then
v = Join(Application.Transpose(Application.Transpose(r1)), ", ")
Cells(n, 1) = WorksheetFunction.Proper(v)
Cells(n, 2).Resize(, r1.Count).Clear
r2.Cut Cells(n, 3)
End If
Next n
End Sub
i have been having problems with getting my code to run through its conditional loop and stopping. Here is what I have:
Do While True
Dim i As Integer
i = 2
If Cells(i, 1).Value <> "" And Not IsError(Cells(i, 2).Value) Then
Range(Cells(i, 1), Cells(i, 22)).Copy
Range(Cells(i, 1), Cells(i, 22)).PasteSpecial
i = i + 1
Else
Exit Do
End If
Loop
What I'm trying to do is to get the program to check if one cells isn't empty and if another doesn't have an error in it, if that condition is met, then the program would copy a certain row and re-paste it as just it's values since some of the cells in the row is a formula. For some reason the loop doesn't exit and Excel crashes, am I missing something?
the i = 2 should be outside
Dim i As Integer
i = 2
Do While True
If Cells(i, 1).Value <> "" And Not IsError(Cells(i, 2).Value) Then
Range(Cells(i, 1), Cells(i, 22)).Copy
Range(Cells(i, 1), Cells(i, 22)).PasteSpecial
i = i + 1
Else
Exit Do
End If
Loop
Two points :
The i = 2 must be outside the while loop.
Don't use Copy and PasteSpecial. Using the clipboard will give lots of problems later on. Additionally PasteSpecial likes you to be specific with "what" PasteSpecial action you're using. Rather assign values directly.
Dim i As Integer, Dataset As Variant
i = 2
Do While True
If Cells(i, 1).Value <> "" And Not IsError(Cells(i, 2).Value) Then
'This seems silly, but it overwrites the cell with its value.
Dataset = Range(Cells(i, 1), Cells(i, 22)).Value
Range(Cells(i, 1), Cells(i, 22)).Value = Dataset
i = i + 1
Else
Exit Do
End If
Loop
I have a spreadsheet where column A information starts on row 6 and I have the unique values from this list as headers across the top in Row 1 starting at column D. What I want to do is if a cell in column A matches a header row, copy the information in the cell in column C to the corresponding Header.
ORIGINAL FORMAT
DESIRED FORMAT
Here is the code that I have tried but it is not giving me the desired results:
For i = 6 To lastRow
For j = 4 To lastColumn
If Cells(i, 1) = Cells(1, j) Then
wksActRawData.Cells(i, 3).Value = wksActRawData.Cells(i, j).Value
End If
Next j
Next i
Assuming you did write lastRow and lastColumn functions, the only error in your code is the data which gets the cell values
If Cells(i, 1) = Cells(1, j) Then
wksActRawData.Cells(i, 3).Value = wksActRawData.Cells(i, j).Value
End If
Which should really be the other way around, plus I'd add a line to clear the old prices, as follows
If Cells(i, 1) = Cells(1, j) Then
Cells(i, j).Value = Cells(i, 3).Value
Cells(i, 3).ClearContents
End If
It did work for me this way