Its a simple code to go to a sheet pull a row, go back to the first one sheet and paste it, then repeat until the value in column A of the inventory changes (New employee) at which point it needs to make a new worksheet to start storing the new data. And repeat until its done.
Dim i As Integer
Dim j As Integer
Set i = 2
Set j = 1
Do While i < 6
Sheets("Inventory").Select
If Cells("i,1").Value = Cells("i-1,1").Value Then
Cells("i:i").Select
Selection.Copy
Sheets("Sheetj").Select
Cells("i,1").Select
Selection.Paste
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
Sheets("Inventory").Select
Cells("i:i").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheetj").Select
Range("A3").Select
ActiveSheet.Paste
i = i + 1
End If
End Sub
Add this:
Loop
Before you end the sub. The i's also shouldn't have double quote if you're referencing what the number I should be. Should be like Cells(i , 1), or Cells(i , i), I'll leave you up to fix the rest.
Sorry, misread your original post. fixed.
I would do something like this to add create new sheets for each data group.
Updated: reduced my code now your "sheetj" part is clear
code
Sub Other()
Dim rng1 As Range
Dim rng2 As Range
Dim ws As Worksheet
Set rng1 = Sheets("Inventory").Range("I2:i6")
Set ws = Sheets.Add
For Each rng2 In rng1
If rng2 <> rng2.Offset(-1, 0) Then Set ws = Sheets.Add
rng2.EntireRow.Copy ws.Rows(rng2.Row)
Next
End Sub
Sub test()
Dim i As Integer
Dim j As Integer
i = 2 ' got rid of set
j = 1 ' got rid of set
Do While i < 6
Sheets("Inventory").Select
If Cells("i,1").Value = Cells("i-1,1").Value Then
Cells("i:i").Select
Selection.Copy
Sheets("Sheetj").Select
Cells("i,1").Select
Selection.Paste
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
Sheets("Inventory").Select
Cells("i:i").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("Sheets" & j).Select ' for completeness...
Range("A3").Select
ActiveSheet.Paste
i = i + 1
End If
Loop ' missing this
End Sub
Untested, but i think you use too many selects (tried with .activate ?)
Dim i As long 'long is faster for loops
Dim j As long
i = 2 'dont need set
j = 1
Do While i < 6
with Sheets("Inventory")
If .Cells(i,1).Value = .Cells(i-1,1).Value Then 'i removed the quotes in cells
.range("i:i").Copy Sheets("Sheetj").Cells(i,1)
i = i + 1
Else
Sheets.Add After:=Sheets(Sheets.Count)
j = j + 1
.Cells("i:i").copy Sheets("Sheetj").Range("A3")
i = i + 1
End If
end with
Application.CutCopyMode = False
loop 'you forgot a ending loop
Related
I have a worksheet that has columns 1-8, rows 3 through the last row. I would like to loop through each cell to find out if a value of 1 is present. If it is then that row is copied and inserted for each value of 1, additionally that new row will have a text inserted in cell (13,row) then moved to the next row. This is as far as I got....thanks!
Sub Workcenter()
Application.ScreenUpdating = False
On Error Resume Next
Application.DisplayAlerts = False
On Error GoTo 0
Dim Test As Worksheet
Set TS = Worksheets("Test")
Application.DisplayAlerts = True
For k = 1 To 8
For j = 4 To TS.Cells(Rows.Count, k).End(xlUp).Row
If TS.Cells(j, k).Value = 1 Then TS.Cells.Activate
'TS.Cells.Activate.Row.Select
Rows(ActiveCell.Row).Select
Selection.Copy
Selection.Insert Shift:=xlDown
'ShopOrderNumRow = j
Next j
Next k
End Sub
Will try giving some example knowing that I still don't understand how the inserting is occurring for each cell of a row.
Providing more detail, or example of before/after in your post may help.
As for an example, since you're marking only a single cell in each row, I would suggest Find() for value of 1 to determine if you need to write to that specific cell.
'untested code
sub test()
toggle false
dim rowNum as long
for rowNum = firstRow to lastRow Step 1
with sheets(1)
with .range(.cells(rowNum,1),.cells(rowNum,8))
dim foundCell as range
set foundCell = .find(1)
if not foundCell is nothing then .cells(rowNum,13).value = "text"
end with
end with
next iterator
toggle true
end sub
private sub toggle(val as boolean)
with application
.screenupdating = val
.enableevents = val
end with
end sub
Edit1: Looks like countif() may be the saviour here.
Edit2: Tested code input (untested code part of Edit1)
Sub test()
Dim lastRow As Long: lastRow = 10
Dim firstRow As Long: firstRow = 1
toggle False
Dim rowNum As Long
For rowNum = lastRow To firstRow Step -1
With Sheets(1)
Dim countRange As Range
Set countRange = .Range(.Cells(rowNum, 1), .Cells(rowNum, 8))
Dim countOfOnes As Long
countOfOnes = Application.CountIf(countRange, 1)
If countOfOnes > 0 Then
With .Rows(rowNum)
.Copy
.Offset(1).Resize(countOfOnes).Insert Shift:=xlDown
End With
.Cells(rowNum, 13).Value = "text"
End If
End With
Next rowNum
toggle True
End Sub
Private Sub toggle(val As Boolean)
With Application
.ScreenUpdating = val
.EnableEvents = val
End With
End Sub
Tested using this data:
Output from running code:
I stuck with this problem:
I have this code and it works but I struggle now.
I want the loop this whole code till in Table1 the cell D1 is empty.
Sub strule()
Dim myCellRange As Range
Worksheets("Table1").Select
Code = Range("D1")
Wert = Range("E10")
Worksheets("Table2").Select
Worksheets("Table2").Range("A1").Select
lMaxRows = Cells(Rows.Count, "A").End(xlUp).Row
Range("A" & lMaxRows).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = Code
ActiveCell.Offset(0, 1).Select
ActiveCell.Value = Wert
Sheets("Table1").Select '
Rows("1:10").Select
Selection.Cut
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I've had a guess at what you want... could be completely wrong though.
First of all your original code with all the selecting & activating removed:
Sub strule()
Dim WrkSht1 As Worksheet
Set WrkSht1 = Worksheets("Table1")
'Worksheets("Table1").Select
Dim Code As String
Code = WrkSht1.Range("D1")
Dim Wert As String
Wert = WrkSht1.Range("E10")
Dim WrkSht2 As Worksheet
Set WrkSht2 = Worksheets("Table2")
'Worksheets("Table2").Select
'Worksheets("Table2").Range("A1").Select
Dim lMaxRows As Long
lMaxRows = WrkSht2.Cells(Rows.Count, "A").End(xlUp).Row
WrkSht2.Cells(lMaxRows + 1, 1) = Code 'Lastrow+1 in column A.
WrkSht2.Cells(lMaxRows + 1, 2) = Wert 'Lastrow+1 in column B.
'Range("A" & lMaxRows).Select
'ActiveCell.Offset(1, 0).Select
'ActiveCell.Value = Code
'ActiveCell.Offset(0, 1).Select
'ActiveCell.Value = Wert
WrkSht1.Rows("1:10").Delete shift:=xlUp
'Sheets("Table1").Select '
'Rows("1:10").Select
'Selection.Cut
'Application.CutCopyMode = False
'Selection.Delete Shift:=xlUp
End Sub
Now what I think you want:
Sub strule1()
Dim WrkSht1 As Worksheet
Set WrkSht1 = Worksheets("Table1")
Dim WrkSht2 As Worksheet
Set WrkSht2 = Worksheets("Table2")
Dim lLastRow1 As Long
lLastRow1 = WrkSht1.Cells(Rows.Count, "A").End(xlUp).Row
Dim x As Long
Dim lLastRow2 As Long
Dim Code As String
Dim Wert As String
For x = 1 To lLastRow1 Step 10
Code = WrkSht1.Cells(x, 4) 'Loop 1 grabs from row 1, loop 2 from row 11
Wert = WrkSht1.Cells(x + 9, 5) 'Loop 1 grabs from row 10, loop 2 from row 20
lLastRow2 = WrkSht2.Cells(Rows.Count, "A").End(xlUp).Row
WrkSht2.Cells(lLastRow2 + 1, 1) = Code 'Lastrow+1 in column A.
WrkSht2.Cells(lLastRow2 + 1, 2) = Wert 'Lastrow+1 in column B.
Next x
WrkSht1.Rows("1:" & x).Delete shift:=xlUp
End Sub
My first question on Stackoverflow, and a newbe, so please bare with me.
I am trying to sort out an excel sheet with 411,278 rows, about stock market data.
My code is as follows:
Sub Macro1()
'
' Macro1 Macro
'
Range("C6:C1577").Select
Selection.Copy
Range("D5").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B6:C1577").Select
Range("C6").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
I am trying to insert the above code in a loop that will increment all the numbers within the loop by 1.
For example (the next phase in the loop will be):
Sub Macro1()
'
' Macro1 Macro
'
Range("C7:C1578").Select
Selection.Copy
Range("D6").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("B7:C1578").Select
Range("C7").Activate
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
End Sub
Thanks!
A Data Transpose
The following will copy only the values (no formatting or formulas).
Adjust the values in the constants section. Note that you can choose a different worksheet for the result to leave your source data intact.
The Code
Option Explicit
Sub transposeValues()
' Define constants.
Const srcName As String = "Sheet1"
Const srcColumns As String = "B:D"
Const srcFirstRow As Long = 5
Const dstName As String = "Sheet1"
Const dstFirstCell As String = "B5"
Const dCount As Long = 1573
' Define workbook.
Dim wb As Workbook: Set wb = ThisWorkbook
' Define Source Range.
Dim rng As Range
With wb.Worksheets(srcName).Columns(srcColumns)
Set rng = .Resize(.Worksheet.Rows.Count - srcFirstRow + 1) _
.Offset(srcFirstRow - 1).Find( _
What:="*", _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious)
If rng Is Nothing Then
Exit Sub
End If
Set rng = .Resize(rng.Row - srcFirstRow + 1).Offset(srcFirstRow - 1)
End With
' Write values from Source Range to Data Array.
Dim Data As Variant: Data = rng.Value
' Define Result Array.
Dim srCount As Long: srCount = UBound(Data)
Dim Remainder As Long: Remainder = srCount Mod dCount
Dim drCount As Long
If Remainder = 0 Then
drCount = srCount / dCount
Else
drCount = Int(srCount / dCount) + 1
End If
Dim dcCount As Long: dcCount = dCount + 1
Dim Result As Variant: ReDim Result(1 To drCount, 1 To dcCount)
' Declare counters.
Dim i As Long, j As Long, k As Long
' Write values from Data Array to Result Array.
If drCount = 1 And Remainder > 0 Then
i = 1
Else
For i = 1 To drCount + (Remainder <> 0) * 1 ' In VBA 'True = -1'.
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
For j = 3 To dcCount
k = k + 1
Result(i, j) = Data(k, 2)
Next j
Next i
End If
' Write the remainder of values in Data Array to Result Array.
If Remainder > 0 Then
k = k + 1
For j = 1 To 2
Result(i, j) = Data(k, j)
Next j
If Remainder > 1 Then
For j = 3 To 1 + Remainder
k = k + 1
Result(i, j) = Data(k, 2)
Next j
End If
End If
' Write values from Result Array to Destination Range.
With wb.Worksheets(dstName).Range(dstFirstCell).Resize(, dcCount)
.Resize(.Worksheet.Rows.Count - .Row + 1).ClearContents
.Resize(drCount).Value = Result
End With
End Sub
Please do not try this code without taking precautions.
Sub Macro1()
Dim Rng As Range
Dim Rstart As Long ' start of range row
Dim Rend As Long ' end of range row
Dim Target As Range ' destination of copy action
Dim DelRng As Range ' range to delete
Rstart = 6
Rend = 1577
Application.ScreenUpdating = False
Do
Set Rng = Range(Cells(Rstart, "C"), Cells(Rend, "C"))
Set Target = Cells(Rstart - 1, "D")
Set DelRng = Range(Cells(Rstart, "B"), Cells(Rend, "C"))
Rng.Copy
TargetPasteSpecial Paste:=xlPasteAll, _
Operation:=xlNone, _
SkipBlanks:=False, _
Transpose:=True
DelRng.Delete Shift:=xlUp
Rstart = Rstart + 1
Loop Until Rstart = Rend
With Application
.CutCopyMode = False
.ScreenUpdating = False
End With
End Sub
Primary precaution to take is to understand the code. Start and End rows are specified at the top. They are used to set 3 ranges in columns C, D and B:C. Initially, they are precisely your 3 ranges Range("C6:C1577"), Range("D5"), Range("B6:C1577"). The code copies from the first range to the second and then deletes the third. It does so without selecting anything because once VBA is told where a range is it doesn't need to select it.
You will notice that there is no equivalent of your Range("C7").Activate. That's because C7 is within the range Range("B6:C1577") which is earmarked for destruction. It makes no difference which cell in it is active. However, I have some doubt about the deletion and whether you actually meant to delete only this cell (which your code doesn't do). Please check my code against your intentions in this regard.
Now the critical part. That's the loop. On each iteration the 3 ranges are moved one row down. The line of code requiring your attention is this one.
Loop Until Rng.Row = Rend
The loop will continue until the first row of the first range is equal to Rend. That means that there will be 1571 loops - probably enough time to have a coffee and a chat even while screen updating is turned off. But even this fearsome number is definitely wrong. Your question gives no clue as to your needs but I guess it should be like Loop Until Rng.Row = (411278 - Rend), give or take 1. I didn't want to enter into an argument about this final, last row (which tends to be omitted in loops) while not believing that your number of rows is invariable. I think it should be replaced with a formula that finds the last existing row in a particular column.
However, your question was how to advance the ranges. My code does that beautifully. Enjoy the show.
This code is supposed to transfer pivot table data from one workbook to other, works fine for a few loops, however, the row increment which is being tried isn't catching up after a few loops. I'm not sure why it messes up after running a few loops!
Sub copypivotdata()
Dim x As Workbook
Dim y As Workbook
Dim n As String, ws As Worksheet
Dim pvt As Range
Dim i, i2 As Integer
Set x = Workbooks("WorkbookA.xlsm")
Set y = Workbooks("WorkbookB.xlsm")
i = 2
'Now, transfer values from x to y:
x.Activate
For Each ws In ActiveWorkbook.Worksheets
'With ActiveWorkbook.ActiveSheet
If ws.Name <> "Main Sheet" And ws.ChartObjects().Count <> 0 Then
ws.Activate
Else:
GoTo nextws
End If
ws.Activate
Range("A1048576").Select
Selection.End(xlUp).Select
Range(Selection, Selection.End(xlUp)).Select
Range(Selection, Selection.End(xlToRight)).Select
Set pvt = Selection
i2 = Selection.Rows.Count
'MsgBox i2
y.Activate 'activate other workbook
'With
y.Sheets("Pivot data").Range("C" & i, "D" & i2 + i) = pvt.Value
i = i2 + 2
i2 = 0
nextws: Next ws
y.Activate
End Sub
The loop logic was incorrect.. Just realized.
"i = i2 + 2" is incorrect. Should be i = i + i2
I have up to 6 cells with potential data coming from 6 different places. I am trying to get only the first three cells with data transferred to another sheet
Private Sub Transfer_Data()
Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants, 23).copy
Sheets("sheet2").Range("A1:A3").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End Sub
This is what i have i know i am missing allot
This is how I would do it:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 1
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j + 1
End If
If j > 3 Then Exit For
Next i
End Sub
EDITED:
Sub Transfer_Data()
Dim i As Long, j As Long
j = 3
For i = 1 To 6
If Sheets("Sheet1").Cells(i, 1).Value <> "" Then
Sheets("Sheet2").Cells(j, 1).Value = Sheets("Sheet1").Cells(i, 1).Value
j = j - 1
End If
If j = 0 Then Exit For
Next i
End Sub
Untested, there may be another, more elegant way of doing this:
Private Sub TransferData()
Dim cellCount as long
Dim cell as range
Dim rangeToCopy as range
For each cell in Sheets("sheet1").Range("A1:A6").SpecialCells(xlCellTypeConstants) ' 23 is unnecessary, as you get all XlSpecialCellsValue constants by default
' See https://learn.microsoft.com/en-us/office/vba/api/excel.range.specialcells
cellCount = cellCount + cell.cells.count
If not (rangeToCopy is nothing) then
Set rangeToCopy = application.union(rangeToCopy, cell)
Else
Set rangeToCopy = cell
End if
If cellCount = 3 then exit for
Next cell
If not (rangeToCopy is nothing) then
rangeToCopy.copy
Sheets("sheet2").Range("A1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End if
End Sub
I know this already answered, but how about a crazy one-liner?
Sub TransferData()
ThisWorkbook.Sheets("Sheet2").Range("A1:A3").Value2 = WorksheetFunction.Transpose(Split(Replace$(Join(WorksheetFunction.Transpose(ThisWorkbook.Sheets("Sheet1").Range("A1:A6").Value2), ","), ",,", ","), ","))
End Sub