I have this sub in Excel 2010 that transfers columns from other sheets and inserts it into a table. The new table has 7 columns. The first 5 are just copying right from the other sheets and they work fine. The last two, however, are supposed match the Program Number from the new table against the Program Number in one of two other sheets and copy the column from there. These are the two that don’t work. It doesn’t throw any errors, the columns just don’t populate.
This is the excerpt that isn’t working. I’m quite new to VBA in excel so any assistance would be greatly appreciated.
Sub Program_List()
Dim SiteNoTransfer As String
Dim SiteNo As String
Dim TransferCol(7) As Integer
Dim Row As Integer
Dim RowTransfer As Integer
Dim StartColumn As Integer
Dim rSrc As Range
Dim rDst As Range
TransferCol(0) = 0 'Nothing (placeholder)
TransferCol(1) = 10 'Proj No, from Data
TransferCol(2) = 1
TransferCol(3) = 3
TransferCol(4) = 11
TransferCol(5) = 15
TransferCol(6) = 10 'From Sheet 1 or 2
TransferCol(7) = 17 'From Sheet 1 or 2
StartColumn = 45
Row = 7
Do While True
SiteNo = Worksheets("RESULTS").Cells(Row, StartColumn - 11)
If SiteNo = "" Then
Exit Do
ElseIf Not SiteNo = "" Then
RowTransfer = 4
Do While True
SiteNoTransfer = Worksheets("Data").Cells(RowTransfer, TransferCol(1))
If SiteNoTransfer = "END" Then
Exit Do
ElseIf SiteNoTransfer = SiteNo Then
Worksheets("RESULTS").Cells(Row, StartColumn + 1).Interior.Color = RGB(0, 255, 255)
Worksheets("Data").Cells(RowTransfer, TransferCol(1)).Interior.Color = RGB(0, 100, 255)
For i = 1 To 4
If Not TransferCol(i) = 0 Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Program").Cells(RowTransfer, TransferCol(i))
End If
Next
For i = 5 To 5
If Not TransferCol(5) = 0 Then
Set rSrc = Sheets("Data").Cells(RowTransfer, TransferCol(5))
Set rDst = Sheets("RESULTS").Cells(Row, StartColumn + i)
rDst = rSrc
rDst.NumberFormat = "yyyy"
Exit Do
End If
Next
'Where the code stops
For i = 6 To 6
If Not TransferCol(6) = 0 Then
If Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet1").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet1").Cells(RowTransfer, TransferCol(6))
End If
ElseIf Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 2").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 2").Cells(RowTransfer, TransferCol(6))
End If
Next
For i = 7 To 7
If Not TransferCol(7) = 0 Then
If Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 1").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 1").Cells(RowTransfer, TransferCol(7))
End If
ElseIf Worksheets("RESULTS").Cells(Row, StartColumn + 1) = Worksheets("Sheet 2").Cells(Row, TransferCol(1)) Then
Worksheets("RESULTS").Cells(Row, StartColumn + i) = Worksheets("Sheet 2").Cells(RowTransfer, TransferCol(7))
End If
Next
End If
RowTransfer = RowTransfer + 1
Loop
End If
Row = Row + 1
Loop
End Sub
EDIT: This is about what the sheets look like.
Sheet 1
| Project No. | Col 2 |... | Col 6 | Col 7
+------------+---------+-------+---------+
| 12-3456 | Date|... | 1234| 0987
+------------+---------+-------+---------+
| 22-3456 |Date|...| 2234 | 9876
+------------+---------+-------+---------+
Sheet 2
| Project No. | Col 2 |... | Col 6| Col 7
+------------+---------+-------+---------+-------------
| 32-3456 | Date |... | 3234 | 8765
+------------+---------+-------+---------+------------+
Results
| Project No. | Col 2 |... | Col 6 | Col 7
+------------+---------+-------+---------+-------------
| 12-3456 | Date |... | 1234 | 0987
+------------+---------+-------+---------+------------+
| 22-3456 | Date |... | 2324 | 9876
+------------+---------+-------+---------+------------+
| 32-3456 | Date |... | 3234 | 8765
So to clarify, in case this is still messy, if the Project Number matches Sheet1, then it takes column 6 from Sheet1, and the same for column 7.
I wound up doing this with VLOOKUP. So it looked something like:
=IFERROR(IFERROR(VLOOKUP(RC,'GROUP1'!A:O,6, FALSE),VLOOKUP(RC,'GROUP2'!A:O,6, FALSE),"")
Much clearer now and thanks for posting the columns. It appears as if though your If statement is returning "False" value and that's why the column is not populating.
However, I think you will need to post more of your code as it is currently not possible to debug it without knowing the values of Row, StartColumn, & RowTransfer.
But your code aside for a second, let me see if I understand correctly:
You check if the "Project Number" in A2 of the results sheet is matching the "Project Number" of A2 in Sheet1. If not then you check A3, A4, A5 of Sheet1 until you find a match.
If no match is found you start looking the same way in Sheet2.
Once the match is found, let say in A5 of Sheet1, you take the values of Columns 2-7 of the corresponding row in Sheet1 and copy them to the row with the same "Project Number" in the results sheet.
Please confirm if I understand you correctly so maybe a I can try and put together a code. Also, it would be helpful if you explain what is the reason for having 2 sheets (Sheet1 & Sheet2) as opposed to having just 1.
Related
I have a sheet in which Column "A" contains values. I want to collect the row numbers in a new sheet where string "Code: " is found.
I want to write VBA code to achieve this.
For example :
Sheet1 :
RowNo | Column A
------|---------
1 | Hello World
2 | Good morning
3 | Code: 46904A65
4 | Excuse
5 | Code: 4523S45
Output Sheet :
RowNo | Column A
------|---------
1 | 3
2 | 5
Explanation : String "Code: " found in 3rd and 4th row of sheet 1. So output sheet contains those row numbers in it.
The following code is not working :
Set stTempData = Sheets("Output Sheet")
stTempData.Select
Set mainsheet = Sheets("Sheet1")
mainsheet.Select
k = Range("a65536").End(xlUp).Row
i = 1
Do While i < k
Set r = stTempData.Range("a65536").End(xlUp).Offset(1, 0)
If InStr(ActiveSheet.Cells(i, 0).Value, "Code:") > 0 Then
r.Offset(i, 0).Value = ActiveCell.Row - 1
j = i
r.Offset(j + 1, 1).Value = ActiveCell.Row - 2
End If
i = i + 1
Loop
Put this in A1 in the output sheet:
=IFERROR(AGGREGATE(15,6,ROW(Sheet1!$A$1:$A$5)/(ISNUMBER(SEARCH("Code",Sheet1!$A$1:$A$5))),ROW(1:1)),"")
And copy down till you get blanks.
As to your code:
There is no column 0 So your Cells() needs to change to 1. Also you do not want to offset r. One more thing you had activesheet and activecell which was throwing it off.:
Set stTempData = Sheets("Output Sheet")
stTempData.Select
Set mainsheet = Sheets("Sheet1")
mainsheet.Select
k = Range("a65536").End(xlUp).Row
i = 1
Do While i <= k
Set r = stTempData.Range("a65536").End(xlUp).Offset(1, 0)
If InStr(mainsheet.Cells(i, 1).Value, "Code:") > 0 Then
r.Value = mainsheet.Cells(i, 1).Row
End If
i = i + 1
Loop
I would like to create a VBA macro that will auto number all cells in column 'A' to a single decimal place, if and only if they have a value in column 'B'. Every time there is a row that does not have a value in column 'B', column 'A' should re-start numbering at the next integer.
IE:
|COLUMN A | COLUMN B|
|:-------:|:-------:|
| 1.1 | TEXT |
| 1.2 | TEXT |
| 1.3 | TEXT |
| 1.4 | TEXT |
| 1.5 | TEXT |
| | *NO TEXT* |
| 2.1 | TEXT |
| 2.2 | TEXT |
| 2.3 | TEXT |
| | *NO TEXT* |
| 3.1 | TEXT |
| 3.2 | TEXT |
| 3.3 | TEXT |
| 3.4 | TEXT |
I think this is pretty self-explanatory, but post up if anything confuses you:
Option Explicit
Private Sub numberCells()
Dim totalRows As Long
Dim i As Long
Dim baseNumber As Long
Dim count As Integer
totalRows = ActiveSheet.UsedRange.Rows.count
baseNumber = 1
i = 2
Do While i <= totalRows
If Range("B" & i).Value <> "" Then
count = count + 1
Range("A" & i).Value = baseNumber & "." & count
Else
baseNumber = baseNumber + 1
count = 0
End If
i = i + 1
Loop
End Sub
I like using .Areas,
Here's my version
Sub Do_It_Good()
Dim RangeArea As Range, c As Range, LstRw As Long, sh As Worksheet, Rng As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "B").End(xlUp).Row + 1
Set Rng = .Range("B2:B" & LstRw)
y = 0
For Each RangeArea In Rng.SpecialCells(xlCellTypeConstants, 23).Areas
y = y + 1
x = 0
For Each c In RangeArea.Cells
c.Offset(, -1) = y & "." & 1 + x
x = x + 1
Next c
Next RangeArea
End With
End Sub
I need help in creating a macro in Excel wherein it grabs a certain cell and copies the entire row x number of times depending on the cell's contents.
To make it clear, let's say I have 2 rows:
| Order # | Item | Qty |
| 30001 | bag | 3 |
| 30002 | pen | 1 |
What I want the macro to do is grab the number under the Qty column and copy the entire row and insert a new line with the exact same contents under it. The number of times it does this depends on the number in the Qty cell. Also, it appends a three digit number in the Order # cell to make it a unique reference point. What the end-result should be:
| Order # | Item | Qty |
| 30001-001 | bag | 1 |
| 30001-002 | bag | 1 |
| 30001-003 | bag | 1 |
| 30002-001 | pen | 1 |
It's hard to explain it here but I hope you get the point. Thanks in advance, gurus!
The following code supports blank lines in the middle of the data.
If Qty = 0, it won't write the Item in the output table.
Please insert at least 1 row of data, because it won't work if there is no data :)
Option Explicit
Sub caller()
' Header at Row 1:
' "A1" = Order
' "B1" = Item
' "C1" = Qty
'
' Input Data starts at Row 2, in "Sheet1"
'
' Output Data starts at Row 2, in "Sheet2"
'
' Sheets must be manually created prior to running this program
Call makeTheThing(2, "Sheet1", "Sheet2")
End Sub
Sub makeTheThing(lStartRow As Long, sSheetSource As String, sSheetDestination As String)
Dim c As Range
Dim rOrder As Range
Dim sOrder() As String
Dim sItem() As String
Dim vQty As Variant
Dim sResult() As String
Dim i As Long
' Reads
With ThisWorkbook.Sheets(sSheetSource)
Set rOrder = .Range(.Cells(lStartRow, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1)) ' It will work if there are blank lines in the middle!
i = rOrder.Rows.Count
ReDim sOrder(1 To i)
ReDim sItem(1 To i)
ReDim vQty(1 To i)
i = 1
For Each c In rOrder
sOrder(i) = Trim(c.Text)
sItem(i) = Trim(c.Offset(0, 1).Text)
vQty(i) = c.Offset(0, 2).Value
i = i + 1
Next c
End With
' Processes
sResult = processData(sOrder, sItem, vQty)
' Writes
ThisWorkbook.Sheets(sSheetDestination).Range("A" & lStartRow).Resize(UBound(sResult, 1), UBound(sResult, 2)).Value = sResult
End Sub
Function processData(sOrder() As String, sItem() As String, vQty As Variant) As String()
Dim i As Long
Dim j As Long
Dim k As Long
Dim sResult() As String
j = WorksheetFunction.Sum(vQty) ' That's why vQty had to be Variant!
ReDim sResult(0 To j, 1 To 3)
k = 0
For i = 1 To UBound(sOrder)
For j = 1 To vQty(i)
sResult(k, 1) = sOrder(i) & "-" & Format(j, "000")
sResult(k, 2) = sItem(i)
sResult(k, 3) = "1"
k = k + 1
Next j
Next i
processData = sResult
End Function
I hope it helps you. I had fun making it!
One way: Walk down the qty column inserting as needed then jumping to the next original row;
Sub unwind()
Dim rowCount As Long, cell As Range, order As String, i As Long, r As Long
Set cell = Range("C1")
rowCount = Range("C" & rows.Count).End(xlUp).Row
For i = 1 To rowCount
order = cell.Offset(0, -2).Value
For r = 0 To cell.Value - 1
If (r > 0) Then cell.Offset(r).EntireRow.Insert
cell.Offset(r, 0).Value = 1
cell.Offset(r, -1).Value = cell.Offset(0, -1).Value
cell.Offset(r, -2).Value = order & "-" & Format$(r + 1, "000")
Next
Set cell = cell.Offset(r, 0)
Next
End Sub
I think what I'm trying to do is pretty basic, but I'm brand new to VBA so I'm getting stuck and the answers I've found are close, but not quite right.
I have a list of row entries, like this:
1 4 32 2 4
2 6 33 1 3
1 4 32 2 4
4 2 30 1 5
Notice that rows 1 and 3 are duplicates. I'd like to only have a single instance of each unique row but I don't want to just delete the duplicates, I want to report how many of each type there are. Each row represents an inventory item, so deleting duplicate entries without indicating total quantity would be very bad!
So, my desired output would look something like this, where the additional 6th column counts the total number of instances of each item:
1 4 32 2 4 2
2 6 33 1 3 1
4 2 30 1 5 1
My data sets are larger than just these 5 columns, they're closer to 10 or so, so I'd like to put that last column at the end, rather than to hardcode it to the 6th column (i.e., column "F")
Update:
I found some code that worked with minor tweaking, and it worked this morning, but after messing around with some other macros, when I came back to this one it was telling me that I have a "compile error, wrong number of arguments or invalid property assignment" and it seemed to be unhappy with the "range". Why would working code stop working?
Sub mcrCombineAndScrubDups2()
For Each a In range("A1", Cells(Rows.Count, "A").End(xlUp))
For r = 1 To Cells(Rows.Count, "A").End(xlUp).Row - a.Row
If a = a.Offset(r, 0) And a.Offset(0, 1) = a.Offset(r, 1) And a.Offset(0, 2) = a.Offset(r, 2) Then
a.Offset(0, 4) = a.Offset(0, 4) + a.Offset(r, 4)
a.Offset(r, 0).EntireRow.Delete
r = r - 1
End If
Next r
Next a
End Sub
Assuming that your data starts from A1 on a worksheet named ws1, the following code removes the duplicated rows. Not by shifting the whole table but deleting the entire row.
Sub deletedupe()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim row1 As String
Dim row2 As String
i = 1
j = 1
k = 1
Do While Sheets("ws1").Cells(i, 1).Value <> ""
row1 = ""
j = 1
Do While Sheets("ws1").Cells(i, j).Value <> ""
row1 = row1 & Sheets("ws1").Cells(i, j).Value & " "
j = j + 1
Loop
k = i + 1
Do While Sheets("ws1").Cells(k, 1).Value <> ""
row2 = ""
j = 1
Do While Sheets("ws1").Cells(k, j).Value <> ""
row2 = row2 & Sheets("ws1").Cells(k, j).Value & " "
j = j + 1
Loop
If row1 = row2 Then
Sheets("ws1").Rows(k).EntireRow.Delete
Else
k = k + 1
End If
Loop
i = i + 1
Loop
End Sub
So i have a matrix formatted as so:
| | joe | michelle | tom |
|:-----: |:---: |:--------: |:---: |
| red | 1 | 0 | 1 |
| blue | 0 | 1 | 0 |
| green | 0 | 0 | 0 |
I'm trying to write VBA in excel to create two columns based on this table. If the cell inside the matrix is equal to "1", then I want to write the column name and row name into a list. So for example, because row "red" has a "1" in columns "joe" and "tom", and row "blue" has a "1" under "michelle", my new table would be like this:
| joe | red |
| tom | red |
| michelle | blue |
Here is the VBA i wrote so far, but it doesn't work and i hit a road block.
sub subname()
dim i as integer
for i = 1 to 3
if cells(2,i).value=1 then
cell(5,i).value = cells(1,i).value
end if
next i
end sub
You have only one cycle ...
Dim x As Integer
Range("B19").Select
x = 4
For i = 1 To 3 ' Row
For e = 1 To 3 ' Column
If ActiveCell.Offset(i, e).Value = "1" Then
x = x + 1
ActiveCell.Offset(x, 0).Value = ActiveCell.Offset(0, e).Value
ActiveCell.Offset(x, 1).Value = ActiveCell.Offset(i, 0).Value
End If
Next
Next
I consider B19 the top_left corner of the table ...
Ok the correct code is:
Dim i As Integer
For i = 1 To 3
If Cells(2, i + 1).Value = 1 Then
Cells(5, 1).Value = Cells(1, i + 1).Value
End If
Next i
If the top_left of the table is A1 The error is the reference of i. You need to add 1 or change the cycle from 2 to 4.The second "error" it's to put the value in cell(5,i) instead of cells(5,1). In that case you have to put the name in a fix position. In a cycle you change in Cells(5+e,1)...
You can use this code also.
Sub prabhat()
Dim rng As Range
Dim r As Integer
Dim c As Integer
Dim lastRow As Integer
Dim lastRow2 As Integer
Set rng = Range("a2:d4")
For Each dng In rng
lastRow = Range("E" & Rows.Count).End(xlUp).Row
lastRow2 = Range("F" & Rows.Count).End(xlUp).Row
If dng.Value = 1 Then
r = dng.Row
c = dng.Column
Range("E" & lastRow + 1).Value = Cells(r, 1).Value
Range("F" & lastRow2 + 1).Value = Cells(1, c).Value
End If
Next dng
End Sub