In Excel for Mac:
I have 2 tabs (wkst1 and wkst2) and need to populate a third one (wkst3)
wkst1 has one column with names listed
e.g.
A
B
wkst2 has two columns
X 1
Y 4
I need to populate wkst3 to ensure all rows in wkst2 are associated to each name listed in wkst1.
e.g. my wished result would be:
A X 1
A Y 4
B X 1
B Y 4
Can you suggest the code I should use?
I managed to solve the problem on my own.
Sub writeall()
Dim Ws As Worksheet
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim X As Long
Dim Y As Long
Dim count As Long
Application.ScreenUpdating = False
Set Ws = ActiveWorkbook.Worksheets(1)
Set Ws1 = ActiveWorkbook.Worksheets(2)
Set Ws2 = Workbooks("xxxx.xlsx").Sheets("2017") ' xxxx is the name of the xlsx
count = 1
For X = 2 To Ws2.Range("A" & Rows.count).End(xlUp).Row
For Y = 1 To Ws1.Range("A" & Rows.count).End(xlUp).Row
count = count + 1
Ws.Cells(count, 1).Value = Ws2.Cells(X, 1).Value
Ws.Cells(count, 2).Value = Ws1.Cells(Y, 2).Value
Ws.Cells(count, 3).Value = Ws1.Cells(Y, 1).Value
Next Y
Next X
Application.ScreenUpdating = True
MsgBox ("Spreadsheet updated")
End Sub
Related
I have the following VBA code for excel
Dim k As Integer, z As Integer
Dim sourceSht As Worksheet
Dim destSht As Worksheet
z = 0
Set sourceSht = Sheets("sheet1")
Set destSht = Sheets("sheet2")
DoEvents
For k = 1 To 5000
If k < 3 Or (k - 1) Mod 3 <> 0 Then
z = z + 1
sourceSht.Columns(k).Copy destSht.Columns(z)
End If
Next
This code was working perfectly for rows (changed this part"sourceSht.Columns(k).Copy destSht.Columns(z)").
but I can not make it work for columns. I want excel to copy the first 2 columns then skip the third one, then copy 2 again, skip one and etc... can somebody help me and explain what am I doing wrong?
I'm going to ignore the use of mod and do a Step 3 with the loop:
Dim i as Long, j as Long
For i = 1 to 5000 Step 3
With sourceSht
If j = 0 Then
j = 1
Else
j = j + 2 'Copying 2 columns over, so adding 2 each time
End If
.Range(.Columns(i),.Columns(i+1)).Copy destSht.Range( destSht.Columns(j), destSht.Column(j+1))
End With
Next i
Something like that should do it for you
Alternate:
Sub tgr()
Dim wsSource As Worksheet
Dim wsDest As Worksheet
Dim rCopy As Range
Dim rLast As Range
Dim LastCol As Long
Dim i As Long
Set wsSource = ActiveWorkbook.Sheets("Sheet1")
Set wsDest = ActiveWorkbook.Sheets("Sheet2")
On Error Resume Next
Set rLast = wsSource.Cells.Find("*", wsSource.Range("A1"), xlFormulas, , xlByColumns, xlPrevious)
On Error GoTo 0
If rLast Is Nothing Then Exit Sub 'No data
LastCol = rLast.Column
Set rCopy = wsSource.Range("A:B")
For i = 4 To LastCol Step 3
Set rCopy = Union(rCopy, wsSource.Columns(i).Resize(, 2))
Next i
rCopy.Copy wsDest.Range("A1")
End Sub
Try this (use count for the number of time you need to copy columns, t for the first columns you need to copy):
Sub copy_columns()
t = 1
Count = 1
Do Until Count = 10
Range(Columns(t), Columns(t + 1)).Copy
Cells(1, t + 3).Select
Selection.PasteSpecial Paste:=xlPasteValues
t = t + 3
Count = Count + 1
Loop
End Sub
I am attempting to write a small section of code to create a new worksheet and insert values from a table in a source worksheet starting at row 2, column 1 thru column 4. Once it reaches the end, I need it to loop to the next row and start over.
The issue I have is that the below code loops back to row 1 of the new worksheet and data is overridden. Is there a simple way to have my loop start on the first blank row down?
[2
Sub SAX()
Dim wsSource As Excel.Worksheet, wsData As Excel.Worksheet
Dim r As Long, c As Long
Set wsData = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsData.Name = "Data"
Set wsSource = ThisWorkbook.Worksheets("Header")
Application.DisplayAlerts = False
r = 2
Do Until Len(Trim(wsSource.Cells(r, 1).Value)) = 0
For c = 1 To 4
wsData.Cells(c * 1, 1).Value = wsSource.Cells(r, c).Value
Next c
ThisWorkbook.Activate
r = r + 1
Loop
Application.DisplayAlerts = True
End Sub
What you want is this, assuming (from screenshot) that you're working with a structured ListObject table:
Sub SAX()
Dim wsSource As Excel.Worksheet, wsData As Excel.Worksheet
Dim i as Long
Dim tbl As ListObject
Dim vals As Variant
With ThisWorkbook
Set wsData = Sheets.Add(After:=.Sheets(.Sheets.Count))
Set wsSource = .Worksheets("Header")
End With
wsData.Name = "Data"
'## Get a handle on the Table object
Set tbl = wsSource.ListObjects(1) 'Modify if needed
Application.DisplayAlerts = False
i = 1 'which row we start putting data on wsData
'## Iterate each row of data in the Table
For Each rng In tbl.DataBodyRange.Rows
'## Dump this row's values in to an array, and transpose it
vals = Application.Transpose(rng.Value)
'## Put the array's values in an appropriately sized range on the wsData sheet:
wsData.Cells(i, 1).Resize(UBound(vals)).Value = vals
'## Increment the destination row number:
i = i + UBound(vals)
Next
Application.DisplayAlerts = True
End Sub
Here we transpose the rng.Value so that we can drop it in a column. We store this in the vals array. We then use the vals array to determine the size of the range where the values will be placed on "Data" sheet, and also use the size of the vals array to increment our i variable, which tells us where to put the next row's data.
Or, maybe even more simply:
For i = 1 to tbl.DataBodyRange.Cells.Count
wsData.Cells(i, 1).Value = tbl.DataBodyRange.Cells(i).Value
Next
This works because a range is indexed by row/column, so we begin counting cell #1 at the top/left, and then wrap to the second row and resume counting, for example, the "cell index" is in this example table:
This can easily be put into a single row or column, just by iterating over the Cells.Count!
Try this...you actually need two Row values, one for data, one for output:
Sub SAX()
Dim wsSource As Worksheet, wsData As Worksheet
Dim lDataRow As Long, lCol As Long, lOut as Long
Set wsData = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
wsData.Name = "Data"
Set wsSource = ThisWorkbook.Worksheets("Header")
Application.DisplayAlerts = False
lDataRow = 2
lOut = 1
Do
For lCol = 1 To 4
wsData.Cells(lOut, 1) = wsSource.Cells(lDataRow, lCol)
Next lCol
lDataRow = lDataRow + 1
lOut = lOut + 1
Loop Until Len(Trim(wsSource.Cells(lDataRow, 1))) = 0
Application.DisplayAlerts = True
End Sub
It would be more efficient to create an array and write all the data at one time.
Sub SAX()
Dim Data, v
Dim x As Long, y As Long
With ThisWorkbook.Worksheets("Header")
With .Range("A1", .Range("A" & .Rows.Count).End(xlUp))
x = WorksheetFunction.RoundUp(.Cells.Count / 4, 0)
ReDim Data(1 To x, 1 To 4)
x = 1
For Each v In .Cells
If y = 4 Then
x = x + 1
y = 1
Else
y = y + 1
End If
Data(x, y) = v
Next
End With
End With
With ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
.Name = "Data"
.Range("A1:D1") = Array(1, 2, 3, 4)
.Range("A2:D2").Resize(UBound(Data, 1)).Value = Data
End With
End Sub
I'm writing a simple formatting macro to alternate the row color for a table in Excel.
I want this macro to be able to format any size table (no matter row/column size).
For example, I want the macro to work when I have a chart with 6 rows 4 columns, or 4 rows 5 columns, or 9 rows 10 columns, etc.
Here's the code I have so far - but I'm getting a runtime error.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For Each Cell In Range(lastRow, lastCol) ''change range accordingly
If Cell.Row Mod 2 = 1 Then
Cell.Interior.ColorIndex = 15 ''color to preference
Else
Cell.Interior.ColorIndex = 14 ''color to preference or remove
End If
Next Cell
End If
I've tried multiple versions of the Range - having the column var come first, having an '&' instead of a comma, etc.
If I use just Range("A1:A" & lastRow), it'll work but just for the data in column A.
I would need it to span across all columns in the chart.
If the tables are all starting from cell A1, change your for statement to:
For Each Cell In Range("A1", Cells(lastRow, lastCol)) ''change range accordingly
Though also, the way your for loop works is that it is changing every cell. It can be optimized to color the row up to the last column at once.
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
Dim i As Integer
For i = 1 To lastRow
If i Mod 2 = 1 Then
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 15
Else
Range("A" & i, Cells(i, lastcol)).Interior.ColorIndex = 14
End If
Next i
End If
Try this:
Dim r As Range
For Each r In MyWs.UsedRange.Rows
If r.Row Mod 2 = 1 Then
r.Interior.ColorIndex = 15
Else
r.Interior.ColorIndex = 14
End If
Next r
Always good to include Option Explicit in your code modules. Try the following:
Option Explicit
Sub test()
Dim MyWS As Excel.Worksheet
Dim objRow As Excel.Range
Dim lastCol As Long
Dim lastRow As Long
Dim lngRow As Long
If ActiveSheet Is Nothing = False Then
Set MyWS = ActiveWorkbook.ActiveSheet
lastCol = MyWS.UsedRange.Columns.Count + 1
lastRow = MyWS.UsedRange.Rows.Count + 1
For lngRow = 1 To lastRow
Set objRow = MyWS.Range(MyWS.Cells(lngRow, 1), MyWS.Cells(lngRow, lastCol))
If lngRow Mod 2 = 1 Then
objRow.Interior.ColorIndex = 15 'color to preference
Else
objRow.Interior.ColorIndex = 14 'color to preference or remove
End If
Next lngRow
End If
End Sub
I have this problem in Excel that I want to solve using Macros in VBA. I have a sheet that contains data in this format:
separator
1
2
6
3
8
342
532
separator
72
28
10
21
separator
38
23
234
What I want to do is to create a VBA macro that creates a new sheet for every series of data (a series starts from the "separator" and ends before the next one or at the end of the initial sheet) and copy respective data in the new sheets.
Example:
1
2
6
3
8
342
532
in sheet1
72
28
10
21
in sheet2 etc.
Thank you very much, I appreciate it!
This copies data from beginning to the first separator ("q"):
Sub macro1()
Dim x As Integer
x = 1
Sheets.Add.Name = "Sheet2"
'Get cells until first q
Do Until Sheets("Sheet1").Range("A" & x).Value = "q"
Sheets("Sheet2").Range("A" & x).Value = Sheets("Sheet1").Range("A" & x).Value
x = x + 1
Loop
End Sub
Try this... (UNTESTED)
Const sep As String = "q"
Sub Sample()
Dim ws As Worksheet, wsNew As Worksheet
Dim lRow As Long, i As Long, rw As Long
'~~> Set this to the relevant worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
'~~> Add a new temp sheet
Set wsNew = ThisWorkbook.Sheets.Add
'~~> Set row for the new output sheet
rw = 1
With ws
'~~> Get the last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the cells from row 2
'~~> assuming that row 1 has a spearator
For i = 2 To lRow
If .Range("A" & i).Value = sep Then
Set wsNew = ThisWorkbook.Sheets.Add
rw = 1
Else
wsNew.Cells(rw, 1).Value = .Range("A" & i).Value
rw = rw + 1
End If
Next i
End With
End Sub
You could use this to avoid Looping every row. As long as you want to delete the original data as well.
SubSample()
Dim x As Integer
Dim FoundCell As Range
Dim NumberOfQs As Long
Dim SheetWithData As Worksheet
Dim CurrentData As Range
Set SheetWithData = Sheets("Sheet4")
NumberOfQs = WorksheetFunction.CountIf(SheetWithData.Range("A:A"), "q")
x = 1
Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", , , , , xlPrevious)
If Not FoundCell Is Nothing Then
Set LastCell = FoundCell.End(xlDown)
Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
Sheets("QSheetNumber" & x).Rows(1).Delete
x = x + 1
Set FoundCell = SheetWithData.Range("A1", SheetWithData.Range("A" & Rows.Count)).Find("q", FoundCell, , , , xlPrevious)
If Not FoundCell Is Nothing Then
Set LastCell = FoundCell.End(xlDown)
Set CurrentData = SheetWithData.Range(FoundCell, LastCell)
Sheets.Add.Name = "QSheetNumber" & x 'Get cells until first q
CurrentData.Cut Sheets("QSheetNumber" & x).Range("A1")
Sheets("QSheetNumber" & x).Rows(1).Delete
x = x + 1
Else
Exit Sub
End If
Else
Exit Sub
End If
End Sub
If I have all data in one very long column like this:
A
B
C
1
2
3
D
E
F
4
5
6
G
H
I
7
8
9
Is it possible to move data like this?
Column1 Column2 Column3 Column4 Column5 Column6
A B C 1 2 3
D E F 4 5 6
G H I 7 8 9
I tried paste special+transpose , but I have more than 10 thousands records , so it will take me too much time in using this method.
I'm new in excel and macro , thank you very much.
Edit:
I even tried to transpose all data into many columns then select the column I want to make them all into one column with this macro:
Sub OneColumn()
' Jason Morin as amended by Doug Glancy
' http://makeashorterlink.com/?M19F26516
''''''''''''''''''''''''''''''''''''''''''
'Macro to copy columns of variable length
'into 1 continuous column in a new sheet
''''''''''''''''''''''''''''''''''''''''''
Dim from_lastcol As Long
Dim from_lastrow As Long
Dim to_lastrow As Long
Dim from_colndx As Long
Dim ws_from As Worksheet, ws_to As Worksheet
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set ws_from = ActiveWorkbook.ActiveSheet
from_lastcol = ws_from.Cells(1, Columns.Count).End(xlToLeft).Column
'Turn error checking off so if no "AllData" trying to delete doesn't generate Error
On Error Resume Next
'so not prompted to confirm delete
Application.DisplayAlerts = False
'Delete if already exists so don't get error
ActiveWorkbook.Worksheets("AllData").Delete
Application.DisplayAlerts = True
'turn error checking back on
On Error GoTo 0
'since you refer to "AllData" throughout
Set ws_to = Worksheets.Add
ws_to.Name = "AllData"
For from_colndx = 1 To from_lastcol
from_lastrow = ws_from.Cells(Rows.Count, from_colndx).End(xlUp).Row
'If you're going to exceed 65536 rows
If from_lastrow + ws_to.Cells(Rows.Count, 1).End(xlUp).Row <= 65536 Then
to_lastrow = ws_to.Cells(Rows.Count, 1).End(xlUp).Row
Else
MsgBox "This time you've gone to far"
Exit Sub
End If
ws_from.Range(ws_from.Cells(1, from_colndx), ws_from.Cells(from_lastrow, _
from_colndx)).Copy ws_to.Cells(to_lastrow + 1, 1)
Next
' this deletes any blank rows
ws_to.Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
But it will just join all column into one but not the column selected.
For Remou reference:
Here is the output:
A D G
B E H
C F I
1 4 7
2 5 8
3 6 9
You can look at something in these lines:
Sub TransposeColumn()
Dim rng As Range
Dim ws As Worksheet
Set rng = Worksheets("Input").UsedRange
Set ws = Worksheets("Output")
j = 1
k = 1
For i = 1 To rng.Rows.Count
If rng.Cells(i, 1) = vbNullString Then
j = j + 1
k = 1
Else
''ws.Cells(k, j) = rng.Cells(i, 1)
''EDIT
ws.Cells(j, k) = rng.Cells(i, 1)
k = k + 1
End If
Next
End Sub
This is how I do the same thing... it creates the new table in column C over...based on your example that there is a blank cell between each group of data:
Sub TransposeGroups()
Dim RNG As Range, Grp As Long, NR As Long
Set RNG = Range("A:A").SpecialCells(xlConstants)
NR = 1
For Grp = 1 To RNG.Areas.Count
RNG.Areas(Grp).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Grp
End Sub
This should work for any length of data and "groups" of up to 8500 within the data.
This also uses the AREAS method, but this overcomes the groups limitation by using subgroups, so it should work with any size dataset.
Sub TransposeGroups2()
'Uses the AREAS method and will work on any size data set
'overcomes the limitation of areas by working in subgroups
Dim RNG As Range, rngSTART As Range, rngEND As Range
Dim LR As Long, NR As Long, SubGrp As Long, Itm As Long
LR = Range("A" & Rows.Count).End(xlUp).Row
NR = 1
SubGrp = 1
Set rngEND = Range("A" & SubGrp * 10000).End(xlUp)
Set RNG = Range("A1", rngEND).SpecialCells(xlConstants)
Do
For Itm = 1 To RNG.Areas.Count
RNG.Areas(Itm).Copy
Range("C" & NR).PasteSpecial xlPasteAll, Transpose:=True
NR = NR + 1
Next Itm
If rngEND.Row = LR Then Exit Do
Set rngSTART = rngEND.Offset(1)
SubGrp = SubGrp + 1
Set rngEND = Range("A" & (SubGrp * 10000)).End(xlUp)
Set RNG = Range(rngSTART, rngEND).SpecialCells(xlConstants)
Loop
End Sub