1400 separate excell files need to take all data from each file row by row from range A1:Q38. need that data in a single column list in order of each original row. Need to read row A1:Q1 and write to A1:A17 then read A2:Q2 and write to A18:A34 continue until each file is read. Need data in a new workbook. Would like to ignore writing empty cells to new list if possible. following code will do job in one worksheet. Need it to work against 1400 files programmatically.
Sub readvalues()
row2 = 1
For Row = 1 To 38
For col = 1 To 17
READCELL = Worksheets("sheet1").Cells(Row, col).Value
Worksheets("sheet2").Cells(row2, 1) = READCELL
row2 = row2 + 1
Next col
Next Row
End Sub
What you need to use is called Transpose. PasteSpecial allows you to paste using transposed cells. (Rows become columns and columns become rows, as in a Matrix)
Dim targetWorkbook As Workbook
Dim rowCount As Integer
rowCount = 1
Set targetWorkbook = Workbooks.Add
Application.DisplayAlerts = False
targetWorkbook.SaveAs Filename:="C:/MyData/TransposedRow" & rowCount
ActiveSheet.UsedRange.Cells.Copy
targetWorkbook.Sheets(1).Cells.PasteSpecial Transpose:=True
Application.CutCopyMode = False
rowCount = rowCount + 1
Related
Hi - I have been stuck on some VBA - I have extracted some data which is displayed in columns - the problem is some of the data in column 3 has been put into 2 cells - meaning all the corresponding cells in those 2 rows have been merged. A way round this which I have done using VBA is to split any merged cells within the same row and duplicate their contents in the new unmerged cells - this essentially has created a lot of duplicate data - so dont really want to do this
I am not sure if anyone has got any ideas on the best solution for this. All i really want to do is concatenate Column 3A data with column 3B data -so putting them in the same cell and removing the merged cells- but this can be dynamic and not every row in this column may be split like this
See below:
I have used this code: this only removes the merged cells and duplicates the data in the new empty cells from their corresponding cells.
Dim rng As Range, xCell As Range
Set WorkRng = recwbk.Worksheets(1).Range("A3:M" & recwbk.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each rng In WorkRng
If rng.MergeCells Then
With rng.MergeArea
.UnMerge
.Formula = rng.Formula
End With
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
But what i am trying to achieve is the below
Sub Tester22()
Dim col As New Collection, maxRows As Long, n As Long
Dim c As Range, c2 As range
'loop over row2 and check for merged cells
For Each c In ActiveSheet.Range("B2:G2").Cells
n = c.MergeArea.Rows.Count
If n > 1 Then
If n > maxRows Then maxRows = n 'tracking max # rows merged
c.UnMerge
Else
col.Add c 'not merged: deal with these later
End If
Next c
'loop over the unmerged cells and pull content from the rows below
For Each c In col
For n = 2 To maxRows
Set c2 = c.Offset(n - 1, 0)
c.Value = c.Value & vbLf & c2.Value
c2.ClearContents
Next n
Next c
End Sub
I want to copy rows from sheet1 only when the cell in column B has a specific value which is a string. I used the code below, which seems to copy the rows, but just pastes empty cells in the new sheet.
I think the problem is that it is looking for a value, not a string (can a string be a value?). Do I need to define the cell as a string? Sorry if these are silly questions - new to coding.
Sub copy_rows()
Sheets.Add After:=Sheets(1)
Sheets(2).Name = "New"
For Each cell In Sheets(1).Range("B:B")
If cell.Value = "banana" Then
matchRow = cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("New").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
End If
Next
End Sub
Here's an example of sheet 1:
apple 1 2 1
banana 1 3 5
carrot 1 1 1
banana 1 2 3
And here's the New sheet:
banana 1 3 5
banana 1 2 3
Also, I didn't attempt this in my code but it would be good if there were no space between the rows.
Thanks
This is my edited code above to work with your sample data. Make sure that the workbook that contains the sheet that you want to copy from is active when this is run.
Sub copy_rows()
'create the new sheet
Sheets.Add After:=Sheets(1)
Sheets(2).Name = "New"
'get the number of rows you need to check
Dim RowCount As Integer
RowCount = WorksheetFunction.CountA(Sheets(1).Range("A:A"))
'iterate over the rows
For r = 0 To RowCount - 1
this_cell = Sheets(1).Range("A1").Offset(r, 0)
If this_cell = "bananas" Then
'iterate over the columns and copy cells to new sheet
For c = 0 To 3
Sheets(2).Range("A1").Offset(x, c) = Sheets(1).Range("A1").Offset(r, c)
Next c
'counter for the offset to next row in new sheet
x = x + 1
End If
Next r
End Sub
I am trying to create a summary list for people in a downstream application to feed several of my production machines. Each machine is going to have their own tab to request material, and I want all of their requests to be summarized on one tab (called "Core_Cutter_List").
So basically I am trying to create a VBA that will copy over a row from spreadsheet "2" into the next blank line on spreadsheet "Core_Cutter_List". I want it to copy if there is text in column A and column G is blank. I have limited knowledge of VBA. The code that I found was able to only test for one of my criteria which was that column G is blank, but basically it runs through every single cell on my file. Do you know how I can add the other criteria of column A having text in it so that it doesn't look through every cell on my sheet? Thanks for any help!
Sub Test()
'
' Test Macro
'
Sheets("2").Select
For Each Cell In Sheets(1).Range("G:G")
If Cell.Value = "" Then
matchRow = Cell.Row
Rows(matchRow & ":" & matchRow).Select
Selection.Copy
Sheets("Core_Cutting_List").Select
ActiveSheet.Rows(matchRow).Select
ActiveSheet.Paste
Sheets("2").Select
End If
Next
End Sub
If you need two conditions, then you should write them carefully in the IF statement with And:
Something like If cell.Value = "" And Len(cell.Offset(0,-6)) Then should be workable.
Using Select is a bit not advisable, but it works at the beginning - How to avoid using Select in Excel VBA
The Sub bellow does the following
Determine the last used row in Worksheets("2") based on values in column A
Determine the last used col in Worksheets("2") based on values in row 1
Determine the last used row in Worksheets("Core_Cutter_List") based on values in column A
Loop through all used rows in Worksheets("2")
If the cell in col A is not empty And cell in col G is empty
Copy entire row to next empty row in Worksheets("Core_Cutter_List")
Increment next empty row for Worksheets("Core_Cutter_List")
Loop to the next used row in Worksheets("2")
Option Explicit
Public Sub CopyRows()
Dim ws1 As Worksheet, ws2 As Worksheet, ws1r As Range, ws2r As Range
Dim ws1lr As Long, ws1lc As Long, ws2lr As Long, i As Long
Set ws1 = ThisWorkbook.Worksheets("2")
Set ws2 = ThisWorkbook.Worksheets("Core_Cutter_List")
ws1lr = ws1.Range("A" & Rows.Count).End(xlUp).Row 'last row in "2"
ws1lc = ws1.Cells(1, Columns.Count).End(xlToLeft).Column 'last col in "2"
ws2lr = ws2.Range("A" & Rows.Count).End(xlUp).Row + 1 'last row in "Core_Cutter"
For i = 1 To ws1lr
If Len(ws1.Cells(i, "A")) > 0 And Len(ws1.Cells(i, "G")) = 0 Then
Set ws1r = ws1.Range(ws1.Cells(i, 1), ws1.Cells(i, ws1lc))
Set ws2r = ws2.Range(ws2.Cells(ws2lr, 1), ws2.Cells(ws2lr, ws1lc))
ws2r.Value2 = ws1r.Value2
ws2lr = ws2lr + 1
End If
Next i
End Sub
My test file
Worksheets("2")
Worksheets("Core_Cutter_List")
I have the following macro to read lines on Sheet1 and insert that number of lines and copy the data on Sheet2. It works fine for only 1 iteration.
Sub InsertRow()
Dim ws2 As Worksheet
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
Set sh = Sheet1
Set ws2 = Sheet2
RowCount = 0
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "" Then
Exit For
Else
ws2.Rows(rw.Row).Copy
ws2.Rows(rw.Row + 1).Insert Shift:=xlDown
End If
RowCount = RowCount + 1
Next rw
ws2.Rows(1).Delete
MsgBox ("Done")
End Sub
I need help figuring out how to tell it keep going and not finish until it comes across two consecutive blank cells. The worksheet will always be separated by one blank row and then data until the end of the sheet. Right now I have removed the header because it always starts there and I get a bunch of duplicate header rows instead of data rows. Is there a way to tell it to start inserting at row 2 and then keep iterating until 2 consecutive blank rows? The delete needs to be at the end of each iteration because the insert will always be X and since one row already exists on Sheet2 I will always need X-1.
An example worksheet for Sheet1 is this, for each line that exists on Sheet2 it will insert a row and copy the data already in that row on sheet1. When all teh rows are inserted, I will then move Columns B, C, and D over to Sheet2 and delete Sheet1
ColA ColB ColC ColD
Srvr 9 12 Data
Srvr2 7 22 Data
Srvr9 15 14 Data
Blank row
Srvr3 17 18 Data
Srvr19 18 27 Data
blank row
A quick modification should continue the code until two blank rows:
Change If sh.Cells(rw.Row, 1).Value = "" Then to If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row+1, 1).Value = "" Then
I am not sure what you are asking at the end of your question though about starting to insert at row 2 and x-1, etc.
I ended up going with the following to accomplish the task. #PartyHatPanda thanks for helping me find 2 empty rows back to back. I incorporated that into my final code. I added an ElseIf and that did the trick. To deal with the blank rows, I left them in there that way the rows line up with the copy and paste, then I wrote a delete sub to get rid of the blank rows.
Sub InsertRow()
Dim ws2 As Worksheet
Dim sh As Worksheet
Dim rw As Range
Dim RowCount As Integer
Set sh = Sheet1
Set ws2 = Sheet2
RowCount = 0
For Each rw In sh.Rows
If sh.Cells(rw.Row, 1).Value = "" And sh.Cells(rw.Row + 1, 1).Value = "" Then
Exit For
ElseIf sh.Cells(rw.Row, 1).Value = "" Then
ws2.Rows(rw.Row).ClearContents
Else
ws2.Rows(rw.Row).Copy
ws2.Rows(rw.Row + 1).Insert Shift:=xlDown
End If
'RowCount = RowCount
Next rw
MsgBox ("Done")
End Sub
Hello and first let me say thank you!
I use Excel to capture user requirements and descriptions. I then take that information and clean it up and paste into presentation docs, apply formatting, paste into Powerpoint, etc. It can be 100s of lines in total that this is done for. What I'm looking for is a macro that I can apply to data once it is pasted into Excel. The data will be text, non-numeric
I have a macro that I use to insert a blank row as every other row. I then do everything else manually (macro shown below).
What I'm looking for is a macro that inserts a blank row, then offsets Column 2 by 1 row down. then pastes column 1 into column 2(without copying the blank cells over my already existing data in column 2).
I've pasted a link to an image of what I'm looking for. I've also tried to show below (numbers are column 1, letters are column 2).
2 columns to 1 column - desired result
1 A 2 B3 C
Result I want:
1
A
2
B
3
C
My current "Blank Row" Macro:
Sub insertrow()
' insertrow Macro
Application.ScreenUpdating = True
Dim count As Integer
Dim X As Integer
For count = 1 To 300
If ActiveCell.Value <> "" Then
ActiveCell.Offset(1, 0).Select
Range(ActiveCell, ActiveCell.Offset(0, 0)).EntireRow.Insert
ActiveCell.Offset(1, 0).Select
For X = 1 To 1
Next X
Else
ActiveCell.Offset(1, 0).Range("a1").Select
End If
Next count
End Sub
This should work, but you'll have to adjust a little for your exact layout and needs.
Sub mergeColumns()
Dim mergedData As Variant
ReDim mergedData(1 To 600)
dataToProcess = Range("A2:B301")
For i = 1 To 300
mergedData(i * 2 - 1) = dataToProcess(i, 1)
mergedData(i * 2) = dataToProcess(i, 2)
Next i
Range("B2:B601") = WorksheetFunction.Transpose(mergedData)
End Sub
The following does what you need without inserting blank rows. It also calculates what the last row is on the sheet that has 2 columns so that you don't need to hard-code when the loop will end.
The comments should help you understand what is happening each step of the way. You can then modify this to work with your particular workbook. There are a lot of ways you could go about this. I chose to put the pivoted result on a second sheet.
Sub PivotTwoColumnsIntoOne()
Dim wb As Workbook
Dim src As Worksheet
Dim tgt As Worksheet
Dim rng As Range
Dim cell As Range
Dim lastRow As Long
Dim targetRow As Long
Set wb = ThisWorkbook
' set our source worksheet
Set src = wb.Sheets("Sheet1")
' set our target sheet (where the single column will be)
Set tgt = wb.Sheets("Sheet2")
' get the last row on our target sheet
lastRow = src.Range("A" & src.Rows.Count).End(xlUp).Row
' set the starting point for our target sheet
targetRow = 1
Set rng = src.Range("A1:A" & lastRow)
For Each cell In rng
With tgt.Range("A" & targetRow)
' get the value from the first column
.Value = cell.Value
' get the value from the second column
.Offset(1).Value = cell.Offset(, 1).Value
.HorizontalAlignment = xlLeft
End With
targetRow = targetRow + 2
Next cell
End Sub