What code can give me this result?
Copy value in A1, Worksheet 1 to Worksheet 2 column A 4 times (e.g A1 - A4)
Then Copy value in A2, Worksheet 1 to Worksheet 2 column A 4 times again (e.g A5 - A8), and so on.
Thank you!
Sub Moveit
'declare your variables
dim r as range
dim t as range
dim i as integer
'initialise your ranges
set r = worksheets(1).range("A1")
set t = worksheets(2).range("a1")
do 'begin looping
for i = 1 to 4 'do 4 times
t=r
set t = t.offset(1,0) 'move target down 1
next i
set r = r.offset(1,0) 'move source down 1
loop until r= "" 'repeat until you run out of sources
End Sub
Related
I have an Excel table which may contain such:
Screenshot of content from a table, columns C and D
It may be much longer
on top of column D may be an empty cell, but after that it is always the same sequence of contents repeating.
I want to copy and paste in another sheet, with transpose, the contents of the neighboring cells, that is in C, so it would look like:
a screenshot from destination table
It is easy to copy the header, but I am completely unable to have the code loop through and copy all the column C contents that appear left to what is between 1tst and 27tst in the original column D, until all of the blocks of data are copied.
To complicate things even further, I want all empty cells in this destination table to take the value from the cell above, basically filling the blanks that way. This would then look like
Final look of the destination table
In this example, the Words "Algeria | DZ" have to be automatically copied down. The cell under "24tst" remains blank as there is nothing but the header preceding this row.
I have absolutely no starting code here, as these data already made a long process from a Word file through a csv using Ruby, and then the csv is read in and reformatted into various sheets in the Excel file with already long line sof code. That all works so far, but these are my missing steps.
Any help is greatly appreciated. I only started coding again 3 weeks ago, after having never programmed in VBA but years ago in perl and R.
-- In response to VBasic2008 and to try that out I made now a test spreadsheet that looks this way:this is closer to what it really looks like
I changed the constants here:
enter code hereConst sName As String = "Tabelle1" ' Source Worksheet Name
enter code hereConst sFirst As String = "C2" ' Source First Cell Address
enter code hereConst tName As String = "Tabelle2" ' Target Worksheet Name
enter code hereConst tFirst As String = "B1" ' Target First Cell Address
The groups will actually be constant in length, actually more than 11, but that can be fixed later.
These:
1tst
2tst
3tst
11tst
4tst
22tst
23tst
24tst
25tst
26tst
27tst -
I pasted this already into target sheet.
What I get from my test using my thus modified solution from VBasic2008 is this:
Afghanistan | AF Åland Islands | AX Albania | AL Algeria | DZ American Samoa | AS Belgium | BE Belize | BZ 24tst Bermuda | BM Bhutan | BT Bolivia | BO
Bonaire, Sint Eustatius and Saba | BQ Bosnia and Herzegovina | BA Botswana | BW Algeria | DZ Brazil | BR Christmas Island | CX Cocos (Keeling) Islands | CC Colombia | CO Comoros | KM n/a Congo | CD
This is almost perfect, except for it should not, in the first row in the target sheet after the headers, copied down the "24tst". Can this still be tweaked?
A Copy Transpose
This will work correctly only if the data is consistent i.e. 11 rows of data and 1 empty (Next-Group) row (can be changed in the constants section) i.e. if you have 5 data sets, there has to be 60 rows of data. If there is 65, only 60 will be processed and if there is 59, only 48 will be processed.
The following image shows what the current setup in the code will produce (without the formatting).
The Code
Option Explicit
Sub transposeData()
Const sName As String = "Sheet1" ' Source Worksheet Name
Const sFirst As String = "A2" ' Source First Cell Address
Const tName As String = "Sheet1" ' Target Worksheet Name
Const tFirst As String = "D1" ' Target First Cell Address
Const NoE As Long = 11 ' Number of Elements
Const NoER As Long = 1 ' Number of Empty Rows
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Worksheet ('ws').
Dim ws As Worksheet
Set ws = wb.Worksheets(sName)
' Define Source First Cell ('First').
Dim First As Range
Set First = ws.Range(sFirst)
' Define Source Last Cell ('Last').
Dim Last As Range
Set Last = First.Offset(ws.Rows.Count - First.Row, 1).End(xlUp)
If Last.Row - First.Row + 1 < NoE Then
GoTo ProcExit
End If
' Define Source Range ('rng').
Dim rng As Range
Set rng = ws.Range(First, Last)
' Write values from Source Range to Source Array ('Source').
Dim Source As Variant
Source = rng.Value
' Define number of Data Sets ('NoDS').
Dim NoDS As Long
NoDS = Int(UBound(Source, 1) / (NoE + NoER))
' Define Target Number of Rows ('NoR').
Dim NoR As Long
NoR = NoDS + 1
' Define Target Array ('Target').
Dim Target As Variant
ReDim Target(1 To NoR, 1 To NoE)
' Declare additional variables for the upcoming loops.
Dim CurrentValue As Variant ' Source Current Value
Dim CurrentLR As Long ' Source Current Last Row
Dim j As Long ' Target Columns Counter
Dim i As Long ' Target Rows Counter
' Write headers.
For j = 1 To NoE
Target(1, j) = Source(j, 2)
Next j
' Write data.
For i = 2 To NoR
CurrentLR = (i - 2) * (NoE + NoER)
For j = 1 To NoE
CurrentValue = Source(CurrentLR + j, 1)
If Not IsEmpty(CurrentValue) Then
Target(i, j) = CurrentValue
Else
Target(i, j) = Target(i - 1, j)
End If
Next j
Next i
' Define Target Worksheet ('ws').
Set ws = wb.Worksheets(tName)
' Define Target First Cell ('First').
Set First = ws.Range(tFirst)
' Define Target Range ('rng').
Set rng = First.Resize(NoR, NoE)
' Write values from Target Array to Target Range.
rng.Value = Target
' Inform user
MsgBox "Data transferred.", vbInformation, "Success"
ProcExit:
End Sub
EDIT
Tiny Change
Instead of Target(i, j) = Target(i - 1, j) use
If i > 2 Then
Target(i, j) = Target(i - 1, j)
End If
I think the easiest way of doing this is looping through cells with headers and checking each value.
When you find your "next-group" cell then trigger some ifs;
Example program which covers your problem below:
Sub solution()
'Set first row
Dim firstrow As Integer
firstrow = 1
'Find last row
Dim lastrow As Integer
lastrow = Cells(Rows.Count, 1).End(xlUp).Row 'Go to bottom of file and jump up to last non-empty cell
'Set first column
Dim firstcolumn As Integer
firstcolumn = 1
'find last column
Dim lastcolumn As Integer
lastcolumn = 2
'Set first cell of target table
Dim targetrange As Range
Set targetrange = Range("E2")
Dim i As Integer
Dim cnt As Integer 'conuter for creating offset (for columns)
Dim cnt2 As Integer 'conuter for creating offset (for rows)
'Copy headers
cnt = 0
For i = firstrow To lastrow
If Cells(i, lastcolumn).Value = "next-group" Then Exit For
Cells(i, lastcolumn).Copy targetrange.Offset(0, cnt)
cnt = cnt + 1
Next i
'Copy data
cnt = 0
cnt2 = 1
For i = firstrow To lastrow
'If we have text "next group"
If Cells(i, lastcolumn).Value = "next-group" Then
cnt = 0 'start with first column
cnt2 = cnt2 + 1 'Start with next row
'This cell is not copied
Else
'cell is copied
Cells(i, firstcolumn).Copy targetrange.Offset(cnt2, cnt)
'column counter is increased
cnt = cnt + 1
End If
Next i
'Change blank cells in current region into formula which points to cell one row above
'targetrange.CurrentRegion.SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
'Same formula but keep cells in first row of data blank istead copying header
Dim targetArea As Range
Set targetArea = targetrange.CurrentRegion
targetArea.Offset(2).Resize(targetArea.Rows.Count - 2).SpecialCells(xlCellTypeBlanks).FormulaR1C1 = "=R[-1]C"
End Sub
I didn't cover case when you have empty cell in first row as you didn't described what you're expecting (at this moment it have same formula so it will be filled with header value).
UPDATE: I didnt put "=" inside R1C1 formula, now its fixed.
UPDATE2: Changed part of filling empty cells so it skips first 2 rows (Headers and first row of data) instead filling it as mentioned in question update
Hi this is my first post and i am newbie when it comes to VBA.
So i tried the last 6 hours to accomplish one task.
I already managed to get the code for the For each loop and it works and copies the value to the existing workbook. But i couldnt find out why it always copies the value to A2 and not further to A3/A4/A5 and so on .
I tried these piece of code " range = range + 1 " but i keep getting runtime errors and it still copies the values to A2 and overwrites it when it gets a new value from the loop.
I think its only a litte change needed but i cant figure it out. :(
Sub copie1()
Dim ws As Worksheet
Dim cell As Range
Dim targetsheet As Worksheet
Dim target As Range
Dim rngTemp As Range
Set wkba = ActiveWorkbook
Worksheets("cop1").Activate
LR = Cells(Rows.Count, "A").End(xlUp).Row
LT = Cells(Rows.Count, "X").End(xlUp).Row
Set rngTemp = Range("X2:X" & LT)
Workbooks.Open Filename:="C:\Users\path......."
Set targetsheet = Worksheets("Data")
Set target= targetsheet.Range("A1")
For Each cell In rngTemp
If cell > 0 Then
target.Offset(1, 0) = cell.Value
End If
target = target+1 '// is this right?
Next cell
End Sub
my goal is the loop through column X in a Workbook and copy every single data that is bigger than 0 ( because there are empty cells & cells with value 0)
and paste it in an existing workbook in range A2/A3/A4 and so on
You can't add the number one to a Range object.
Try replacing target = target+1 '// is this right? with:
Set target = target.Offset(1)
Does this resolve the problem?
SibSib1903, I have added below a simple example that you can easily adapt to your own requirements. It looks at all cell values in column A and any numeric value greater than zero is copied to column C starting in row 1. For example, if column A contains 45 rows with data, and only three of these rows have a numeric value greater than zero, these three values will copied in column C in the first three rows.
Public Sub copieTest()
Dim ws As Worksheet, cell As Range, rngX As Range
Dim tmpVal As Variant, counter As Long
Set ws = ThisWorkbook.Worksheets("cop1")
Set rngX = ws.Range("A1:A" & ws.Cells(ws.Rows.count, 1).End(xlUp).Row)
counter = 1
For Each cell In rngX
tmpVal = Val(Trim(cell.Value))
If tmpVal > 0 Then
ws.Range("C" & counter).Value = tmpVal
counter = counter + 1
End If
Next cell
Set rngX = Nothing: Set ws = Nothing
End Sub
My goal is to rename many worksheets from a worksheet that contains stock market codes. To do this I have the codes in a worksheet called Update. The codes are from A2 to A10. I have set up a For loop to goto the next activeworksheet and as the range value is increased, the worksheet gets renamed to the new cell value in the Update WSheet
The problem I have is that I want the Range value to increase by 1 which will select the next name for the worksheet. I have tried adding 1 to the Range value but did not work
Sub changeWSnames()
Dim sheetname As Worksheet
Dim r As Integer
For r = 1 To 10
ActiveWorkbook.Worksheets(r).Activate
Set sheetname = ActiveWorkbook.ActiveSheet
sheetname.Name = Worksheets("Update").Range("a2").Value
Next r
r = r + 1
End Sub
What I need is too workout is how to increment the .Range("a2").Value , i.e. to increase by 1, example it becomes Range("a3").Value etc etc.
Replace:
sheetname.Name = Worksheets("Update").Range("a2").Value
with:
sheetname.Name = Worksheets("Update").Range("a" & (r+1)).Value
So the first time through the loop we use a2, the next time we use a3, etc.
I am working on an excel sheet. I have titles of data entries, which I wish to copy to other locations on the sheet. The titles range from c3 to c122, and I intend to copy and paste them in cells 70 rows apart. The code below doesn't suffice; I am given error 450 (wrong number of arguments or invalid property assignment).
Option Explicit
Sub Titles()
Dim i As Integer
Dim n As Integer
For i = 151 To 8971 Step 70
For n = 3 To 122 Step 1
Cells.Value(i, 3) = "c" & n
Next n
Next i
End Sub
I desire to have what is in each of cells C3:C122 to be copied into C150, C220,...,C8791. Is this a good approach? Thank you for your help.
There is a lot wrong here.
The double for loop is not required. If the code did work, it would overwrite Cells.Value(i, 3) 120 times on each iteration of i
Cells on its own refers to all the cells on the Active Sheet
Cells.Value returns the cell values as a variant array, in this case a 1,048,576 x 16,384 array
"c" & n creates a string (eg c3) not a cell reference
Try someting like this (note, please check the initial value of rw as there is a contradiction in your post 150 vs 151)
Sub Demo()
Dim ws As Worksheet
Dim rng As Range
Dim cl As Range
Dim rw As Long
Set ws = ActiveSheet
Set rng = ws.Range("C3:C122")
rw = 151 '<--- check if this is right
For Each cl In rng.Cells
ws.Cells(rw, 3).Value = cl.Value
rw = rw + 70
Next
End Sub
Syntax on Cells.Value(i, 3) is wrong it should be Cells(i, 3).Value
Change that and see if everything works as you wanted.
I am new to VBA and have created a macro that will take a value from a cell in worksheet 1 and match it to worksheet 2. If the row is hidden on worksheet 1 it hides the row on worksheet 2. I need to know how to loop it through all rows on worksheet 1 and 2. Then I need it to continue to match worksheet 1 to worksheets 3, 4 & 5. I have looked but can't seem to find anything close in the various forums.
This is what I have that works. I can post the various things I've tried but none work past the first row.
Sub HideRows
If ActiveSheet.Range("A10") = Worksheets("Sheet2").Range("B5") And _
ActiveSheet.Range("A10").EntireRow.Hidden = True Then
Worksheets("Sheet2").Rows(5).EntireRow.Hidden = True
End Sub
I apologize, this is the first time I have ever posted so I am very unfamiliar with how to phrase things or what I should post.
Let me try again:
I have a Master sheet. It has text data in column A on rows 10:185. If any of those rows DO NOT have numeric data in columns B thru T I have written a macro that hides those rows. Rows 10:185 are broken up by category on 5 other worksheets. I want to be able to hide the same rows in the other worksheets that are hidden on the Master sheet. I hope this makes things clearer.
To get the If statement to return true on whether or not the row on Active sheet if hidded you need to change
ActiveSheet.Range("A10").EntireRow.Hidden = True Then
to
ActiveSheet.Range("A10").EntireRow.Hidden Then
This will actually return a TRUE or False You also need an End If for a multi-line If statement. So now your If statement would look like this:
Sub HideRows
If ActiveSheet.Range("A10") = Worksheets("Sheet2").Range("B5") And _
ActiveSheet.Range("A10").EntireRow.Hidden Then
Worksheets("Sheet2").Rows(5).EntireRow.Hidden = True
End If
End Sub
So this macro only looks the value in A10 and tests whether it is equal to B5 on the second worksheet and if Row 10 is hidden on the Active sheet. If you only want to look at Cells A10 on the first and compare them with B5 on all the rest, the code below will do just that (Note: This assumes that the sheets are in order of their name:
Sub HideRows()
Dim i As Integer
For i = 2 To 5
If ActiveSheet.Range("A10") = Sheets(i).Range("B5") And ActiveSheet.Range("A10").EntireRow.Hidden = True Then
Sheets(i).Rows(5).EntireRow.Hidden = True
End If
Next i
End Sub
If you need to do more analysis on cells other that A10 and B5 or you need more than just Sheets 1 through 5, please update your questions so we can help further.
If I understand correctly, you need a macro that checks each row on the master sheet, if it is hidden, then the corresponding row containing that entry on one of the other 5 sheets should also be hidden.
So, assuming the text in column A on the master sheet is now in column B on the other sheets, and assuming that the other 5 sheets are sheets(2) through sheets(6) this should do the trick:
Sub HideRows()
Dim i, j As Integer
Dim x As Range
For i = 10 To 185
'check if the row is hidden, if it isn't then no need to check the other sheets
If ActiveSheet.Cells(i, 1).EntireRow.Hidden Then
'loop through each of the other sheets and look for the value in column B, if found, hide the row.
For j = 2 To 6
'you have to "Set" an object variable such as a range reference
'This Finds the value passed to it in the range that this is called from (in this case the entire B column)
Set x = Sheets(j).Columns(2).Find(ActiveSheet.Cells(i, 1).Value, LookIn:=xlValues)
If Not x Is Nothing Then
x.EntireRow.Hidden = True
End If
Next j
End If
Next i
End Sub
The 2 Versions bellow work the same way
If values in Sheet1.ColA match values in Sheet2.ColB (Sheet3.ColB, etc)
And, if row in Sheet1 is hidden
It will hide (identical) rows in Sheet2, 3, etc
.
Version 1
Option Explicit
Public Sub MatchAndHideRows()
Const COL_1 = "A" 'column with text data in Sheet1 (Master Sheet)
Const COL_2 = "B" 'column with text data in Sheets 2, 3, etc
Dim ws1 As Worksheet, lr1 As Long, arr1 As Variant, d1 As Object
Dim ws2 As Worksheet, lr2 As Long, arr2 As Variant, d2 As Object, r As Long
Set ws1 = Sheet1 'Master Sheet (Or: Set ws1 = ThisWorkbook.Worksheets("Sheet1"))
lr1 = ws1.Cells(ws1.Rows.Count, COL_1).End(xlUp).Row
arr1 = ws1.Range(ws1.Cells(1, COL_1), ws1.Cells(lr1, COL_1)).Formula
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
For r = 10 To lr1 'skip Header rows
If ws1.Rows(r).Hidden Then d1(arr1(r, 1)) = 0 'remember all hidden rows
Next
For Each ws2 In ThisWorkbook.Worksheets 'iterate all sheets
If ws1.Name <> ws2.Name Then 'except Master Sheet (Sheet1)
lr2 = ws2.Cells(ws2.Rows.Count, COL_2).End(xlUp).Row
arr2 = ws2.Range(ws2.Cells(1, COL_2), ws2.Cells(lr2, COL_2)).Formula
For r = 5 To lr2 'skip Headers
If d1.Exists(arr2(r, 1)) Then d2(r) = 0
Next
ws2.UsedRange.Rows.Hidden = False
If d2.Count > 0 Then
ws2.Range("A" & Join(d2.Keys, ",A")).EntireRow.Hidden = True
End If
End If
Next
End Sub
.
Version 2
Public Sub MatchAndHideRowsCheckRowByRow()
Const COL_1 = "A" 'column with text data in Sheet1 (Master Sheet)
Const COL_2 = "B" 'column with text data in Sheets 2, 3, etc
Dim ws1 As Worksheet, lr1 As Long, rng1 As Range, c1 As Range
Dim ws2 As Worksheet, lr2 As Long, rng2 As Range, c2 As Range
Set ws1 = Sheet1 'Master Sheet (Or: Set ws1 = ThisWorkbook.Worksheets("Sheet1"))
lr1 = ws1.Cells(ws1.Rows.Count, COL_1).End(xlUp).Row
Set rng1 = ws1.Range(ws1.Cells(10, COL_1), ws1.Cells(lr1, COL_1)) 'skip Header rows
Application.ScreenUpdating = False
For Each c1 In rng1.Cells 'iterate each cell with data in Sheet1.ColA
If Not IsError(c1) Then 'if current cell doesn't contain an error, continue
For Each ws2 In ThisWorkbook.Worksheets 'iterate all sheets
If ws1.Name <> ws2.Name Then 'except Master Sheet (Sheet1)
lr2 = ws2.Cells(ws2.Rows.Count, COL_2).End(xlUp).Row
Set rng2 = ws2.Range(ws2.Cells(5, COL_2), ws2.Cells(lr2, COL_2))
For Each c2 In rng2.Cells 'iterate each cell in current sheet
If Not IsError(c2) Then
If c1.Value2 = c2.Value2 Then
c2.EntireRow.Hidden = c1.EntireRow.Hidden
End If
End If
Next
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub