I wanna write a macro which copy the 1 cells to another sheet if they contain some value.
Table:
Expectation:
So far I tried this but it copy only last cell from sheet1 to first cell in sheet 2
Sub CopyBasedonSheet1()
Dim i As Integer
Dim j As Integer
Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
Sheet2LastRow = Worksheets("Sheet2").Range("B" & Rows.Count).End(xlUp).Row
For j = 1 To Sheet1LastRow
For i = 1 To Sheet2LastRow
If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then
Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value
Else
End If
Next i
Next j
End Sub
You should do it with one loop, because when you have a row from the first sheet, there is only 1 place where you want to copy it, not many:
Sub CopyBasedonSheet1()
Dim i As Integer
Dim j As Integer
Sheet1LastRow = Worksheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row
i = 1
For j = 1 To Sheet1LastRow
If Worksheets("Sheet1").Cells(j, 2).Value = "a" Then
Worksheets("Sheet2").Cells(i, 1).Value = Worksheets("Sheet1").Cells(j, 1).Value
Worksheets("Sheet2").Cells(i, 2).Value = Worksheets("Sheet1").Cells(j, 2).Value
i = i + 1
End If
Next j
End Sub
Or you may try a different approach altogether which is faster also...
Sub CopyData()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim x, y()
Dim i As Long, j As Long
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
x = ws1.Range("A1").CurrentRegion.Value
ReDim y(1 To Application.CountIf(ws1.Columns(2), "a"), 1 To 2)
j = 1
For i = 1 To UBound(x, 1)
If x(i, 2) = "a" Then
y(j, 1) = x(i, 1)
y(j, 2) = x(i, 2)
j = j + 1
End If
Next i
ws2.Range("A:B").Clear
ws2.Range("A1").Resize(UBound(y, 1), 2).Value = y
End Sub
Related
I am in the process of automating a day to day process. I have ID's in column F and ID2's in column G. How could I write a VBA for filling in the blanks if the IDs in column F are the same? IE ID 123 will always have the ID of 1. In some cases the ID to be used is not the one from above.
Test data:
ID ID2
123 1
123 *Blank*
456 56
456 *Blank*
456 *Blank*
789 23
I have utilized some existing stackoverflow code and tried to adapt it for my needs.
Code:
Sub FindingtheBID()
Dim sht As Worksheet, lastrow As Long, i As Long, j As Long
Set sht = ThisWorkbook.Worksheets("Roots data")
lastrow = sht.Cells(sht.Rows.Count, "F").End(xlUp).Row
For i = 1 To lastrow
If Range("G" & i).Value = "" Then
For j = 1 To lastrow
If Range("C" & i).Value = Range("F" & j).Value And Range("G" &
j).Value <> "" Then
Range("H" & i).Value = Range("G" & j).Value
Exit For
End If
Next j
End If
Next i
End Sub
Something like as follows? I need to do a quick syntax check on other machine.
Sub test()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Roots data")
lastRow = ws.Cells(ws.Rows.Count, "F").End(xlUp).Row
Dim dataArr()
dataArr = ws.Range("F1:G" & lastRow).Value
Dim currentRow As Long
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If Not IsEmpty(dataArr(currentRow, 2)) And Not dict.exists(dataArr(currentRow, 1)) Then
dict.Add dataArr(currentRow, 1), dataArr(currentRow, 2)
End If
Next currentRow
For currentRow = LBound(dataArr, 1) To UBound(dataArr, 1)
If IsEmpty(dataArr(currentRow, 2)) Then
dataArr(currentRow, 2) = dict(dataArr(currentRow, 1))
End If
Next currentRow
ws.Range("F1").Resize(UBound(dataArr, 1), UBound(dataArr, 2)) = dataArr
End Sub
i am having problem with the task i am doing right now. Supposedly,i have a for loop to calculate the MIN and SUM of the used range (tables). Since i have 10 worksheet in the workbook, i added another for loop to loop on each worksheet in the workbook. However, the codes run without error but the output is not as expected. It will calculate even at the unused range. Is there any error on my code?
Sub calc()
Dim ws As Worksheet
Dim y As Workbook
Dim rng As Range
Dim i As Integer, r As Long, j As Long
Set y = ThisWorkbook
For Each ws In y.Worksheets
For Each rng In ws.UsedRange.SpecialCells(xlCellTypeConstants, 3).Areas
If rng.Rows.Count > 1 And rng.Columns.Count = 14 Then
j = 2
r = rng.Cells(rng.Rows.Count, 1).Row + 1
Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
For i = rng.Columns(2).Column To rng.Columns(2).Column + 12
If i = rng.Columns(12).Column Then
Cells(r, i).Formula = "=MIN(" & rng.Columns(j).Address & ")"
j = j + 1
Else
Cells(r, i).Formula = "=SUM(" & rng.Columns(j).Address & ")"
j = j + 1
End If
Next i
End If
Next rng
Next
End Sub
You should always qualify which sheet you are referring to when you use Cells, Range, etc.
For instance, the line
Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
is referring to the active sheet, but you probably want to refer to the sheet that ws is referring to, i.e.
ws.Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
Your code should probably look like:
Sub calc()
Dim ws As Worksheet
Dim y As Workbook
Dim rng As Range
Dim i As Integer, r As Long, j As Long
Set y = ThisWorkbook
For Each ws In y.Worksheets
For Each rng In ws.UsedRange.SpecialCells(xlCellTypeConstants, 3).Areas
If rng.Rows.Count > 1 And rng.Columns.Count = 14 Then
j = 2
r = rng.Cells(rng.Rows.Count, 1).Row + 1
ws.Cells(r, rng.Columns(1).Column).Value = "SUMMARY"
For i = rng.Columns(2).Column To rng.Columns(2).Column + 12
If i = rng.Columns(12).Column Then
ws.Cells(r, i).Formula = "=MIN(" & rng.Columns(j).Address & ")"
j = j + 1
Else
ws.Cells(r, i).Formula = "=SUM(" & rng.Columns(j).Address & ")"
j = j + 1
End If
Next i
End If
Next rng
Next
End Sub
How can I generate the Excel as in the image below via a macro?
Briefly I would like to make:
numbers between a1 and b1 print to d column;
numbers between a2 and b2 print to e column;
numbers between a3 and b3 print to f column.
Columns A and B have thousands of values.
As an alternative, here is a formula solution:
=IF(ROW(D1)>INDEX($A:$B,COLUMN(D1)-COLUMN($C1),2)-INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+1,"",INDEX($A:$B,COLUMN(D1)-COLUMN($C1),1)+ROW(D1)-1)
Though I realize that a formula solution may not be feasible based on this statement:
Columns A and B have thousands of values.
EDIT: Pure array VBA solution:
Sub tgr()
Dim ws As Worksheet
Dim rData As Range
Dim aData As Variant
Dim aResults() As Variant
Dim lMaxDiff As Long
Dim i As Long, j As Long
Dim rIndex As Long, cIndex As Long
Set ws = ActiveWorkbook.ActiveSheet
Set rData = ws.Range("A1", ws.Cells(Rows.Count, "B").End(xlUp))
lMaxDiff = Evaluate("MAX(" & rData.Columns(2).Address(external:=True) & "-" & rData.Columns(1).Address(external:=True) & ")") + 1
aData = rData.Value2
ReDim aResults(1 To lMaxDiff, 1 To rData.Rows.Count)
For i = LBound(aData, 1) To UBound(aData, 1)
If IsNumeric(aData(i, 1)) And IsNumeric(aData(i, 2)) Then
rIndex = 0
cIndex = cIndex + 1
For j = Int(aData(i, 1)) To Int(aData(i, 2))
rIndex = rIndex + 1
aResults(rIndex, cIndex) = j
Next j
End If
Next i
ws.Range("D1").Resize(UBound(aResults, 1), UBound(aResults, 2)).Value = aResults
End Sub
Only because I like puzzles:
Sub u5758()
Dim x As Long
Dim i As Long
Dim oArr() As Variant
Dim arr() As Long
Dim rng As Range
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ActiveSheet
x = 4
With ws
oArr = .Range(.Cells(1, 1), .Cells(.Rows.Count, 2).End(xlUp)).value
For j = LBound(oArr, 1) To UBound(oArr, 1)
ReDim arr(oArr(j, 1) To oArr(j, 2))
For i = LBound(arr) To UBound(arr)
arr(i) = i
Next i
.Cells(1, x).Resize(UBound(arr) - LBound(arr) + 1).value = Application.Transpose(arr)
x = x + 1
Next j
End With
Application.ScreenUpdating = True
End Sub
I like puzzles too.
Sub from_here_to_there()
Dim rw As Long
With Worksheets("Sheet5") '<~~ set this worksheet properly!
For rw = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
If IsNumeric(.Cells(rw, 1)) And IsNumeric(.Cells(rw, 2)) Then
With .Columns(Application.Max(4, .Cells(1, Columns.Count).End(xlToLeft).Column + 1))
.Cells(1, 1) = .Parent.Cells(rw, 1).Value2
.DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, _
Step:=1, Stop:=.Parent.Cells(rw, 2).Value2
End With
End If
Next rw
End With
End Sub
You could use this:
Sub test()
Dim Lastrow As Long
Dim j As Double, i As Double, r As Double
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1") ' Change the name of your sheet
Lastrow = ws.Range("A" & Rows.Count).End(xlUp).Row
j = 4 ' Column D
With ws
For i = 1 To Lastrow ' Start the loop at A1 until the last row in column A
.Cells(1, j) = .Cells(i, 1).Value
r = 1
Do
.Cells(r + 1, j) = .Cells(r, j) + 1
r = r + 1
Loop Until .Cells(r, j) = .Cells(i, 2).Value
j = j + 1
Next i
End With
End Sub
Here's another quick one just for fun:
Sub transposeNfill()
Dim lastRow&, i&, xStart$, xEnd$, xMid$
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To lastRow
xStart = Cells(i, 1)
xEnd = Cells(i, 2)
xMid = xEnd - xStart
Cells(1, i + 3).Value = xStart
Cells(1 + xMid, i + 3) = xEnd
Range(Cells(2, i + 3), Cells(xMid, i + 3)).FormulaR1C1 = "=r[-1]c+1"
Cells.Copy
Cells.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Next i
End Sub
I have a small sample example sheet of data, which will be filled with much more data if I can get this process to work.
What I am trying to do is, based upon the number of cells that are filled in each row, insert the same number of blank lines under that same row and copy everything down all columns that are blank. I have attached two screenshots - a before and after of what the start and end look like, as well as the code used for implementing the blank row insert. So far, all it does is add 8 rows consistently, and is using an older version of Excel. I'm trying to translate it into the new VBA format, but I can't seem to get it to work.
Start:
The result I'm trying to achieve:
Code:
Sub IfYes()
Dim Col As Variant
Dim Y As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim C As Long
Dim StartRow As Long
Col = "AS"
Y = "Y"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "Yes" Then
.Cells(R, Col).Offset(1, 0).Resize(8, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(8, 1).Value = .Cells(R, 1).Value
For C = 1 To 8 Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
I also have another bit of code that I've been trying to use to get this to function properly.
Dim wb1 As Workbook, ws1 As Worksheet
Dim lRow As Long
Dim LastRow As Range
Dim StartRow As Range
Dim i As Long
Set wb1 = Application.Workbooks.Open("Z:\Employee Folders\Jason\crystal spreadsheet - start.xls")
Set ws1 = wb1.Worksheets("AMZStart")
With ws1
For lRow = Cells(Cells.Rows.Count, "B").End(xlUp).Row To 1 Step -1
If Cells(lRow, "B") = "AMZ" Then Rows(lRow).Offset(1, 0).EntireRow.Insert
Next lRow
LastRow = Range("C" & Rows.Count).End(xlUp).Row + 1
StartRow = 1
For i = StartRow To LastRow
If Cells(i, "C") = "" And i > StartRow Then
Cells(i, "C").Formula = "=SUM(C" & StartRow & ":C" & i - 1 & ")"
StartRow = i + 1
End If
Next
End With
End Sub
I find that storing the values in variant arrays can help.
Sub expand_Entries()
Dim v As Long, vAMZs As Variant, vVALs As Variant
Dim rw As Long, c1 As Long, c2 As Long, c As Long, cs As Long
With Worksheets("Sheet2")
c1 = Application.Match("status", .Rows(1), 0)
c2 = .Cells(1, Columns.Count).End(xlToLeft).Column
For rw = .Cells(Rows.Count, 1).End(xlUp).Row To 2 Step -1
cs = Application.CountA(.Cells(rw, c1 + 1).Resize(1, c2 - c1))
If CBool(cs) Then
vVALs = .Cells(rw, 1).Resize(1, c1 - 1).Value2
With .Cells(rw, c1).Resize(1, cs + 1)
vAMZs = .Cells.Value2
.Offset(0, 1).ClearContents
End With
For c = UBound(vAMZs, 2) To LBound(vAMZs, 2) + 1 Step -1
.Cells(rw + 1, 1).Resize(1, c1 - 1).EntireRow.Insert
.Cells(rw + 1, 1).Resize(1, c1 - 1) = vVALs
.Cells(rw + 1, 8) = vAMZs(1, c)
Next c
End If
Next rw
End With
End Sub
You can use a the CountA Worksheet Function inside your IF block to determine the count of filled cells. Then just replace the 8's with the count of each row.
See code:
If .Cells(R, Col) = "Yes" Then
'get count
Dim iCells As Integer
iCells = WorksheetFunction.CountA(.Range("A" & R & ":R" & R))
.Cells(R, Col).Offset(1, 0).Resize(iCells, 1).EntireRow.Insert
.Cells(R, StartRow).Offset(1, 0).Resize(iCells, 1).Value = .Cells(R, 1).Value
For C = 1 To iCells Step 1
.Cells(R, Y).Offset(C, 0).Value = .Cells(R, Col).Offset(0, C).Value
Next C
.Cells(R, Col) = "Done"
End If
Does anyone know how i could expand this code to include 2 more columns of data in its pasting. (columns C and D)
Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
MyArray(j) = Range("A" & i).Value
j = j + 1
k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
End Sub
Currently the code separates this:
TREVDAN 2
CENTRAL 3
GAL FAB 1
Into this:
TREVDAN 1
TREVDAN 1
CENTRAL 1
CENTRAL 1
CENTRAL 1
GAL FAB 1
Try this:
Sub SpecialCopy()
'Assuming A and B columns source columns
Dim i As Long, k As Long
Dim j As Long: j = 1
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("B:B"))
ReDim MyArray(1 To ArrayLength) As String
ReDim ArrayC(1 To ArrayLength) As String 'new
ReDim ArrayD(1 To ArrayLength) As String 'new
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("B" & i).Value
MyArray(j) = Range("A" & i).Value
ArrayC(j) = Range("C" & i).Value 'new
ArrayD(j) = Range("D" & i).Value 'new
j = j + 1
k = k + 1
Loop
Next i
For Each MyCell In Range("a1:a" & ArrayLength)
MyCell.Value = MyArray(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
For Each MyCell In Range("C1:C" & ArrayLength) 'new
MyCell.Value = ArrayC(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
For Each MyCell In Range("D1:D" & ArrayLength) 'new
MyCell.Value = ArrayD(MyCell.Row())
MyCell.Offset(0, 1).Value = 1
Next MyCell
End Sub
This is what I landed up doing:
Sub Splitting()
'splitting up rows
'quantity column: AI
'Data columns: AF,AG,AH,AJ
firstrow = Range("AF2:AJ2")
Dim i As Long, k As Long
Dim j As Long: j = 1
'Next line of code is setting array length equal to the quanity column sum
Dim ArrayLength As Long: ArrayLength = _
Application.WorksheetFunction.Sum(ActiveSheet.Range("AI:AI"))
'Redimentioning all data array to have this fixed array length
ReDim First_Array(1 To ArrayLength) As String
ReDim Second_Array(1 To ArrayLength) As String
ReDim Third_Array(1 To ArrayLength) As String
ReDim Fourth_Array(1 To ArrayLength) As String
For i = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
k = 1
Do While k <= Range("AI" & i).Value
First_Array(j) = Range("AF" & i).Value
Second_Array(j) = Range("AG" & i).Value
Third_Array(j) = Range("AH" & i).Value
Fourth_Array(j) = Range("AJ" & i).Value
j = j + 1
k = k + 1
Loop
Next i
'Data Placement
For Each MyCell In Range("AF2:AF" & ArrayLength)
MyCell.Value = First_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AG2:AG" & ArrayLength)
MyCell.Value = Second_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AH2:AH" & ArrayLength)
MyCell.Value = Third_Array(MyCell.Row())
Next MyCell
For Each MyCell In Range("AJ2:AJ" & ArrayLength)
MyCell.Value = Fourth_Array(MyCell.Row())
Next MyCell
'bring back first row
Range("AF2:AJ2").Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Range("AF3").Select
ActiveSheet.Paste
Range("Af1").Select
Range("AF2:AJ2") = firstrow
'replace quantity column with 1
For Each MyCell In Range("AI2:AI" & ArrayLength + 1)
MyCell.Value = 1
Next MyCell
End sub
Personally I would do it without the arrays...
Sub VBA_Special_Copy_Loop()
Dim lngLastRow As Long, rngSource As Range, iMax As Integer
Dim x As Integer, y As Integer, WF As Object
Set WF = Application.WorksheetFunction
lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row
Columns("AG").Insert
With Range("AG1").Resize(lngLastRow)
.Formula = "=ROW()"
.Value = .Value
.Cells(1) = "Row"
End With
Set rngSource = Range("AF1").Resize(lngLastRow, 6)
iMax = WF.Max(rngSource.Columns(5))
For x = 2 To iMax
If WF.CountIf(rngSource.Columns(5), x) > 0 Then
rngSource.AutoFilter Field:=5, Criteria1:=x
For y = 2 To x
rngSource.Copy Range("AF1").Offset(lngLastRow)
Range("AF1").Offset(lngLastRow).Resize(, 6).Delete Shift:=xlUp
lngLastRow = Range("AF1").Offset(Rows.Count - 1).End(xlUp).Row
Next y
End If
Next x
rngSource.AutoFilter
Range("AF2").Resize(lngLastRow - 1, 6).Sort Key1:=Range("AG1")
Columns("AG").Delete
End Sub