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
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 would like to make every set of eight rows move into columns in Excel for example here is a set with every four rows broken into columns:
From this:
To this:
I've tried this code in VBA which I've seen in a previous question found on https://superuser.com/questions/583595/move-every-7-columns-into-new-row-in-excel
Dim i As Integer, j As Integer, cl As Range
Dim myarray(100, 6) As Integer 'I don't know what your data is. Mine is integer data
'Change 100 to however many rows you have in your original data, divided by seven, round up
'remember arrays start at zero, so 6 really is 7
If MsgBox("Is your entire data selected?", vbYesNo, "Data selected?") <> vbYes Then
MsgBox ("First select all your data")
End If
'Read data into array
For Each cl In Selection.Cells
Debug.Print cl.Value
myarray(i, j) = cl.Value
If j = 6 Then
i = i + 1
j = 0
Else
j = j + 1
End If
Next
'Now paste the array for your data into a new worksheet
Worksheets.Add
Range(Cells(1, 1), Cells(101, 7)) = myarray
End Sub
However, it only seems to work with integers and not data that has both numbers and letters if I am understanding correctly.
I get an error:
Run-time error '13':
Type mismatch
This should do it
Sub movedata()
Dim rowcounter, colcounter, rowcounter2 As Long
colcounter = 3
rowcounter2 = 1
For rowcounter = 1 To Cells(Cells.Rows.Count, 1).End(xlUp).Row
If Cells(rowcounter, 1).Value2 <> "" Then
Cells(rowcounter2, colcounter).Value2 = Cells(rowcounter, 1).Value2
colcounter = colcounter + 1
Else
rowcounter2 = rowcounter2 + 1
colcounter = 3
End If
Next rowcounter
End Sub
So you basically want to transpose the used range of a given sheet? This code may
Option Explicit
Sub transpose()
Dim a As Integer, x As Integer
a = 1 + Cells(1, 1).End(xlToRight).Column
ActiveSheet.UsedRange.Copy
Cells(1, a).Select
Selection.PasteSpecial Paste:=xlPasteAll, transpose:=True
Cells(1, 1).Select
For x = 1 To (a - 1)
Columns(1).Delete
Next x
End Sub
It works as follows:
- find the last used column and define "a" as this columnnumber + 1
- Copy the used range (where your data is)
- transpose into cells(1,a)
- select cells(1,1)
- delete this column (a-1) times
Is this what you are looking for?
How can I compare cells in two rows and and match the lower cell value to the upper cell value, if the two are different? Here is some the same data I am working with and what I hope to see after the code runs.
Before:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [GAS_ADJ], [OBJ_ADJ]
After:
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], [ID_1], [ID_2], [GAS_ADJ], [OBJ_ADJ]
[ID_GLOBAL], [ID_UNIQUE], [ID_REAL], NULL AS [ID_1], NULL AS [ID_2], [GAS_ADJ], [OBJ_ADJ]
I think the code will basically look like this, but I haven't gotten the insert-right working properly.
Sub CompareCellsDiffRows()
Dim bothrows As Range, i As Integer
Set bothrows = Selection
With bothrows
For i = 1 To .Columns.Count
If Not StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
End If
Next i
End With
End Sub
As you may have guessed, I'm dealing with hundreds of fields in several tables and trying to Union everything together, so all these field names have to match up in the correct order.
Thanks.
I am assuming, as per your example, that the first row is the one that will be always complete.
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
With sht
For i = 1 To LastColumn
If StrComp(.Cells(1, i), .Cells(2, i), vbBinaryCompare) <> 0 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
Next i
End With
End Sub
Hope it helps
Regarding your second question (if they are not ordered) and assuming always that the first line is the ones that rules...
Sub CompareRowDifferences()
Dim sht As Worksheet
Dim i, j, LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.Cells.SpecialCells(xlLastCell).Column
j = 0
With sht
For i = 1 To LastColumn
Test = Application.WorksheetFunction.CountIf(Range _
(Cells(2, i), Cells(2, LastColumn + j)), .Cells(1, i).Value2)
If Test >= 1 Then
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = .Cells(1, i).Value2
Else
.Cells(2, i).Insert Shift:=xlToRight
.Cells(2, i).Value2 = "NULL AS " & .Cells(1, i).Value2
End If
j = j + 1
Next i
Range(Cells(2, LastColumn), Cells(2, LastColumn + j)).ClearContents
End With
End Sub
This procedure identifies and uses the row with a higher number of fields (i.e. no-empty cells), and uses it as "model" to update the other row regardless of the position of the fields in the other row.
Sub Headers_Comparison(rInput As Range)
Dim aOut As Variant, aSrc As Variant, aTrg As Variant
Dim bMatch As Byte, bRow As Byte, b As Byte
With WorksheetFunction
Rem Validate Fields in Rows
If .CountA(rInput.Rows(1)) > .CountA(rInput.Rows(2)) Then
bRow = 2
aSrc = .Transpose(.Transpose(rInput.Rows(1).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(2).Value2))
Else
bRow = 1
aSrc = .Transpose(.Transpose(rInput.Rows(2).Value2))
aTrg = .Transpose(.Transpose(rInput.Rows(1).Value2))
End If
aOut = aTrg
For b = 1 To UBound(aSrc)
bMatch = 0
On Error Resume Next
bMatch = .Match(aSrc(b), aTrg, 0)
On Error GoTo 0
aOut(b) = IIf(bMatch > 0, vbNullString, "NULL AS ") & aSrc(b)
Next: End With
rInput.Rows(bRow).Value = aOut
End Sub
It should be called in this manner:
Call Headers_Comparison(rSel) 'update with required range
I think I just figured it out!
Sub CompareRowDifferences()
Dim i As Integer
Dim sht As Worksheet
Dim LastColumn As Long
Set sht = ThisWorkbook.Worksheets("Transposed Fields")
LastColumn = sht.UsedRange.Columns(sht.UsedRange.Columns.Count).Column
For i = 1 To LastColumn
If Not StrComp(sht.Cells(1, i), sht.Cells(2, i), vbBinaryCompare) = 0 Then
' magic happens here
Set Rng = sht.Cells(2, i)
Rng.Insert Shift:=xlToRight
sht.Cells(2, i).Value = "NULL AS " & sht.Cells(1, i).Value
End If
Next i
End Sub
This seems to work. Although, this is a pretty simple solution. I understand it would be much more complex if the order of names the lower row changed. This works ONLY because the names in row 2 match the names in row 1, there are just fewer names. I would love to see what the code would look like if the order of the row 2 names was switch around, compared to the row 1 names.
The code below creates an array of unique values from values in Column A. Each selected array element is used to select a range on the sheet. The range is displayed in a userform Listbox.
I would like help with code that would allow the user to scroll through each array ‘MyarUniqVal’ element via two form buttons Right ‘>>’ and Left ‘<<’. Each time a button is pressed a sequential array item will be selected and a new range will populate the Listbox.
Any help would be greatly appreciated.
Thanks,
Please see the code below:
Sub testRange3()
Dim lastrow, i, j As Long
Dim c As Range, rng As Range
Dim MyArUniqVal() As Variant
ReDim MyArUniqVal(0)
'With ActiveSheet
With ThisWorkbook.Worksheets("Temp")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For i = 1 To lastrow
If .Cells(i, 1).Value <> .Cells(i + 1, 1).Value Then
MyArUniqVal(UBound(MyArUniqVal)) = .Cells(i, 1).Value
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) + 1)
End If
Next
ReDim Preserve MyArUniqVal(UBound(MyArUniqVal) - 1)
End With
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
'Prints out each array to Immediate Window
Debug.Print j
'Prints out unique values from Column A stored in array to Immediate Window
Debug.Print MyArUniqVal(j)
Next
With ThisWorkbook.Worksheets("Temp")
'changed to ActiveSheet
'With ActiveSheet
For Each c In .Range("A1:A" & lastrow)
For j = LBound(MyArUniqVal) To UBound(MyArUniqVal)
If UCase(c.Text) = j Then
'If UCase(c.Text) = "B" Then
If rng Is Nothing Then
Set rng = .Range("B" & c.Row).Resize(, 2)
Debug.Print rng
Else
Set rng = Union(rng, .Range("B" & c.Row).Resize(, 2))
Exit For
Debug.Print rng
End If
End If
Next
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub
See the following code to get you heading the the right direction. I took the approach of adding another listbox that displayed the available prefixes to help the user see what was available and then searching the data column for entries containing the selected prefix.
Hopefully you will be able to adapt the name of the variables and objects to whatever you are currently using. Let me know if anything needs clarification. Best of luck with your project.
My sample form code:
Private Sub cmdBack_Click()
code_frmMain.IncrementValue (0)
End Sub
Private Sub cmdNext_Click()
code_frmMain.IncrementValue (1)
End Sub
Private Sub lstPrefixes_Change()
code_frmMain.DisplayNext
End Sub
Private Sub UserForm_Initialize()
code_frmMain.testRange3
End Sub
My sample program code:
' This subroutine will search column B for the selected value
Sub DisplayNext()
Dim searchTerm As String
Dim lastRow As Long
Dim i As Integer
' clear frmMain.lstResults
frmMain.lstResults.Clear
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
searchTerm = frmMain.lstPrefixes.List(i)
Exit For ' exits once selected item is found
End If
Next i
'Debug.Print searchTerm
With Sheets("Temp")
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
For i = 1 To lastRow
If InStr(Cells(i, 2).Value, searchTerm) Then
frmMain.lstResults.AddItem (Cells(i, 2).Value)
End If
Next i
End Sub
' increments value. input direction: 0 is down and 1 is up
Sub IncrementValue(direction As Integer)
Dim currentIndex As Integer
currentIndex = -1
For i = 0 To frmMain.lstPrefixes.ListCount - 1
If frmMain.lstPrefixes.Selected(i) = True Then
currentIndex = frmMain.lstPrefixes.ListIndex
Exit For ' exits once selected item is found
End If
Next i
' defaults to first item if none selected
If currentIndex = -1 Then
frmMain.lstPrefixes.Selected(0) = True
currentIndex = 0
End If
If direction = 0 Then
' prevents listIndex from being invalid
If currentIndex = 0 Then
frmMain.lstPrefixes.Selected(frmMain.lstPrefixes.ListCount - 1) = True
Else
frmMain.lstPrefixes.Selected(currentIndex - 1) = True
End If
Else
If currentIndex = frmMain.lstPrefixes.ListCount - 1 Then
frmMain.lstPrefixes.Selected(0) = True
Else
frmMain.lstPrefixes.Selected(currentIndex + 1) = True
End If
End If
End Sub
Note that I also added this to the bottom of your testRange3() to use that data that you had already gathered:
For i = 0 To UBound(MyArUniqVal)
frmMain.lstPrefixes.AddItem (MyArUniqVal(i))
Next i
Sample Data:
Running on user form:
In Excel, I created a macro to find and leave only duplicated values across multiple columns within the current selection--removing any cells that were only found once. Well, at least that's what I thought I created anyway, but it doesn't seem to work. Here's what I've got:
Sub FindDupsRemoveUniq()
Dim c As Range
Dim counted() As String
For Each c In selection.Cells
Dim already_found As Boolean
already_found = Contains(counted, c.Text)
If Not (already_found) And WorksheetFunction.CountIf(selection, c) <= 1 Then
c.Delete Shift:=xlUp
ElseIf ("" <> c.Text) And Not (already_found) Then
If Len(Join(counted)) = 0 Then
ReDim counted(1)
Else
ReDim Preserve counted(UBound(counted) + 1)
End If
counted(UBound(counted) - 1) = c.Text
End If
Next c
End Sub
Private Function Contains(ByRef arr() As String, cell As String) As Boolean
Dim i As Integer
Contains = False
If Len(Join(arr)) = 0 Then
Exit Function
End If
For i = LBound(arr) To UBound(arr)
If cell = arr(i) Then
Contains = True
Exit Function
End If
Next
End Function
I had to do this because I had ~180k items across multiple columns, and I had to find anything that was duplicated, and under which column those duplicates are showing in. However, when it completes, it seems that most of the singular instances are still there. I can't figure out why this isn't working.
EDIT: This is what my code ended up looking like based on #brettdj's solution below:
Sub FindDupsRemoveUniq()
Dim lRow As Long
Dim lCol As Long
Dim total_cells As Long
Dim counter As Long
Dim progress_str As String
Dim sel
sel = selection.Value2
total_cells = WorksheetFunction.Count(selection)
counter = 0
progress_str = "Progress: "
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.StatusBar = progress_str & "0 of " & total_cells & " : 0% done"
For lRow = 1 To UBound(sel, 1)
For lCol = 1 To UBound(sel, 2)
counter = counter + 1
Application.StatusBar = progress_str & counter & " of " & total_cells & " : " & Format(counter / total_cells, "0%")
If WorksheetFunction.CountIf(selection, sel(lRow, lCol)) < 2 Then
sel(lRow, lCol) = vbNullString
End If
Next lCol
Next lRow
selection = sel
Application.StatusBar = "Deleting blanks..."
selection.SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
Application.StatusBar = "Done"
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
I tried to speed things up with a few optimizations, though I'm not sure how much they helped. Also, the status bar updates ended up being rather pointless too since Excel got so bogged down. It seemed to give up updating after ~300 iterations. Nonetheless, it did work.
I would suggest using an array, same approach otherwise as simoco
This approach removes the cell contents but doesn't shift the cells up as I wasn't clear that you wanted this
Sub Kill_Unique()
Dim X
Dim lngRow As Long
Dim lngCol As Long
X = Selection.Value2
For lngRow = 1 To UBound(X, 1)
For lngCol = 1 To UBound(X, 2)
If Application.CountIf(Selection, X(lngRow, lngCol)) < 2 Then X(lngRow, lngCol) = vbNullString
Next lngCol
Next lngRow
Selection.Value2 = X
End Sub
If you want delete all cells with unique values from selection, try this one:
Sub test()
Dim rngToDelete As Range, c As Range
For Each c In Selection
If WorksheetFunction.CountIf(Selection, c) = 1 Then
If rngToDelete Is Nothing Then
Set rngToDelete = c
Else
Set rngToDelete = Union(rngToDelete, c)
End If
End If
Next
If Not rngToDelete Is Nothing Then rngToDelete.Delete Shift:=xlUp
End Sub