I am learning VBA,
I have data in sheet1 18 rows with 5 columns and Sheet2 3 rows with 8 columns
I would like to loop data and print in NOTEPAD like,
Rows 1 - 6 from sheet1 then Row 1 from sheet2
Rows 7 - 12 from sheet1 then Row 2 from sheet2
Row 13 - 18 from sheet1 then Row 3 from Sheet2, so on.
Here is my code,
Sub Looping()
Dim str As String
Dim MaxStrLen As String
Dim rest As Integer
Dim Lstr As Integer
Dim LMstr As Integer
Dim MStr As Integer
Dim LR As Range
Dim CNT As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim LRow As Long
Dim LCol As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim i As Long
Dim j As Long
Dim Page_Break As Long
Dim k As Long
Dim PB As Long
Dim x As Long
Dim y As Long
Dim rng As Range
Set rng = Range("A1:E6")
Dim FilePath As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Set ws3 = Sheets("Sheet3")
Open "C:\Users\Antony\Music\Excel Macros\Test.txt" For Output As #2
'''''FIRST FIVE LINES WILL PRINT IN THE NOTEPAD
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
LRow = ws2.Cells(.Rows.Count, 1).End(xlUp).Row
LCol = ws2.Cells(1, .Columns.Count).End(xlToLeft).Column
BlkSize = 6 'data consists of blocks of 6 rows
For i = 1 To LastRow
sOut = vbNullString
LengthRow = i
Do While LengthRow > BlkSize
LengthRow = LengthRow - BlkSize
Loop
'LengthRow points to row where char length is to be taken from
For j = 1 To LastCol
str = .Cells(i, j).Value
If str <> Empty Then
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
Else
MStr = ws2.Cells(LengthRow, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
End If
Next
Print #2, sOut
Next
End With
'''''LAST LINE WILL PRINT IN THE SAME NOTEPAD
With ws3
LRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
slast = vbNullString
For k = 2 To LRow
str = Join(Application.Transpose(Application.Transpose(.Cells(k, "A").Resize(1, LastCol).Value)), "##")
str = Replace(str, "=", vbNullString)
Print #2, str
Next
Endtext = "EODR"
Print #2, slast & Endtext
End With
'Loop
Close #2
End Sub
You can embed the loops:
For i = 0 to 2
For j = 1 to 6
Write Sheet1 row = i * 6 + j to file 'this line not actual code
Next j
Write Sheet2 row = i + 1 to file 'this line not actual code
Next i
Related
I am new to VBA.
I have an excel sheet,
Sheet1 contains values 6 * 6 matrix with values
Variables in each cell
Sheet2 contains Maximum Character length 6* 6 matrix of each values in Sheet1
Maximum Character length of each values in sheet1
I tried to create a notepad and print the values which is in Sheet1 and place the cursor based on the maximum character length.
For Example: In sheet1, Value "First Message" as 13 character so it compare the Sheet2 same row and column as Maximum character length(30) and print in notepad, it should have 17 character length should be empty in notepad. As the same it has to print the same next values in the notepad in the same line which has to start from 31st character.
Finally at every 1st row 6th column, it has to go to newline and start from 1st character position.
Below is my piece of code, Kindly help me to print in the notepad.
Sub myself()
Dim str As String
Dim MaxStrLen As String
Dim rest As Integer
Dim Lstr As Integer
Dim LMstr As Integer
Dim MStr As Integer
Dim LR As Range
Dim CNT As Integer
Dim LastRow As Long
Dim LastCol As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim i As Long
Dim j As Long
Dim h As Long
Dim FilePath As String
Set ws1 = Sheets("Sheet1")
Set ws2 = Sheets("Sheet2")
Open "C:\Users\Antony\Desktop\test.txt" For Output As #2
h = 1
With ws1
LastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
LastCol = .Cells(1, .Columns.Count).End(xlToLeft).Column
Do
For i = 1 To LastRow
For j = 1 To LastCol
str = .Cells(i, j).Value
MStr = ws2.Cells(i, j).Value
Lstr = Len(str)
rest = MStr - Lstr
Set LR = .Range(.Cells(i, j), .Cells(i, LastCol))
'CNT = ActiveSheet.UsedRange.Count
Print #2, str & Space(rest)
If j = Lastcolumn Then
Print #2, vbNewLine
Else: End If
Next
Next
Loop While LR <= LastRow
End With
Close #2
End Sub
Really appreciate your effort in this.
I doubt this code has run ever.
No need for Do loop. BTW While condition is wrong as you compare a range with an int.
Print command prints entire line including crlf, so the line should be assembled in another way, like this:
For i = 1 To LastRow
sOut = vbNullString
For j = 1 To LastCol
str = .Cells(i, j).Value
MStr = ws2.Cells(i, j).Value
Lstr = Len(str)
rest = MStr - Lstr
sOut = sOut & str & Space(rest)
Next
Print #2, sOut
Next
Next
I need help to copy and paste a single row for every cell in another column multiple times starting in the second row.
The raw data looks like this
I need it to look like this
ActiveWorkbook.Names.Add Name:="data1", RefersToR1C1:="=Sheet2!R2C5:R2C7"
ActiveWorkbook.Names("data1").Comment = "" Range("data1").Copy
Range("B1").Select ActiveCell.Offset(1, 0).Select ActiveCell.PasteSpecial
Here is where I get lost. I am not sure how to loop it down and then keep it going and copy column a down and then the defined range again.
I also tried this:
Dim LastRow As Variant
Dim LastRowA As Variant
Dim Row As Range
Dim i As Integer
With Sheets("Store_Item_copy")
LastRow = .Range("A2" & Row.Count).End(xlUp).Row
End With
Range("A2" & LastRow).Copy
For i = 2 To LastRow
i = i + 1
With Sheets("Store_Item_copy")
LastRowA = .Range("A" & .Rows.Count).End(xlUp).Row
End With
LastRowA.Offset(1, 0).Select
ActiveCell.PasteSpecial
Next i
Here is one way to do it using arrays.
Option Explicit
Public Sub PopulateColumns()
Dim wb As Workbook
Dim wsSource As Worksheet
Set wb = ThisWorkbook
Set wsSource = wb.Worksheets("Sheet1") 'Change as appropriate
Dim yearArr()
yearArr = wsSource.Range("E2:F" & wsSource.Cells(wsSource.Rows.Count, "E").End(xlUp).Row).Value
Dim storesArr()
storesArr = wsSource.Range("A2:C" & wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).Row).Value
Dim resultArr()
ReDim resultArr(1 To UBound(storesArr, 1) * UBound(yearArr, 1), 1 To 3)
Dim counter As Long
Dim counter2 As Long
Dim x As Long, y As Long
For x = 1 To UBound(yearArr, 1)
counter2 = counter2 + 1
For y = 1 To UBound(storesArr, 1)
counter = counter + 1
resultArr(counter, 1) = storesArr(y, 1)
resultArr(counter, 2) = yearArr(counter2, 1)
resultArr(counter, 3) = yearArr(counter2, 2)
Next y
Next x
wsSource.Range("A2").Resize(UBound(resultArr, 1), UBound(resultArr, 2)).Value = resultArr
End Sub
I have a description in Column A which contains some error code like ESFB-1 , ESFB-11 etc... with list of error codes in sheet2 a total of about 36 error codes
I have the below code written & works but the only problem is it is treating both ESFB-1 & ESFB-11 as same the list has about 35 error codes with similar nomenclature below is the code
enter code here
Sub sear()
Dim rng As Range
Dim str As String
Dim str1 As String
Dim val1 As Long
Dim val2 As Long
Dim col As Integer
Dim col2 As Integer
Dim row2 As Integer
Dim row As Integer
Dim var As Integer
Dim lastRow As Long
Dim lastrow1 As Long
Dim pos As Integer
lastRow = Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).row
lastrow1 = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row
var = 0
col = 1
row = 2
row2 = 2
pos = 0
Do While var <> 1
Do While row <= lastrow1
Do While pos = 0
str = Sheets("Sheet1").Cells(row, 1).Value
str1 = Sheets("Sheet2").Cells(row2, 1).Value
pos = InStrRev(str, str1, vbTextCompare)
row2 = row2 + 1
If row2 = lastRow Then Exit Do
Loop
If pos <> 0 Then
Cells(row, 7).Value = Sheets("Sheet2").Cells(row2 - 1, 1)
End If
Cells(row, 8).Value = pos & Sheets("Sheet1").Cells(row, 1)
pos = 0
row2 = 2
row = row + 1
Loop
var = 1
Loop
End Sub
Please suggest modifications which can help me find the exact error code from description
Instr will give you false positive like you are getting for ESFB-1 & ESFB-11 and hence you need a more robust check.
Is this what you are trying?
Sub Sample()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim lRow As Long
Dim Arws As Variant, tempAr As Variant
Dim rng As Range, aCell As Range
'~~> Set your sheets here
Set ws1 = Sheet1: Set ws2 = Sheet2
With ws2
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> Store the error codes in an array
Arws = .Range("A1:A" & lRow)
End With
With ws1
lRow = .Range("A" & .Rows.Count).End(xlUp).row
'~~> This is your range from 1st sheet
Set rng = .Range("A2:A" & lRow)
'~~> Loop through all cells and split it's contents
For Each aCell In rng
tempAr = Split(aCell.Value)
'~~> Loop through each split word in the array
For i = LBound(tempAr) To UBound(tempAr)
'~~> Check if exists in array
If ExistsInArray(Trim(tempAr(i)), Arws) Then
'~~> If it does then write to col B
aCell.Offset(, 1).Value = Trim(tempAr(i))
Exit For
End If
Next i
Next aCell
End With
End Sub
'~~> Function to check if a string is int he array
Function ExistsInArray(s As String, arr As Variant) As Boolean
Dim bDimen As Byte, i As Long
On Error Resume Next
If IsError(UBound(arr, 2)) Then bDimen = 1 Else bDimen = 2
On Error GoTo 0
Select Case bDimen
Case 1
On Error Resume Next
ExistsInArray = Application.Match(s, arr, 0)
On Error GoTo 0
Case 2
For i = 1 To UBound(arr, 2)
On Error Resume Next
ExistsInArray = Application.Match(s, Application.Index(arr, , i), 0)
On Error GoTo 0
If ExistsInArray = True Then Exit For
Next
End Select
End Function
Screenshot
I want to copy a range of cells from Workbook1.xlsm and Insert them in Workbook2.xltm.
I will need to insert enough rows in Workbook2 to 'cope' with the size of the data, which will vary. Thanks to jspek I've the following macro but this doesn't insert the rows in Workbook2.
From much Googling I came to this . All I can see is that I need to use .Resize.
My Trial Macro
sub rangeCopy()
Dim sourceRange As Range, loopRange As Range
Dim targetRange As Range
Dim lastRow As Long
Dim sourceCounter As Long
Dim targetCounter As Long
Dim outString As String
Dim startRow As Long
Dim startCol As Long
Dim endCol As Long
Dim colCounter As Long
Set sourceRange = Sheets("Input Sheet").Range("A9:C800")
Set targetRange = Workbooks.Open("C:\Users\j\Documents\Workbook2.xltm").Sheets("Quote").Range("A4")
startRow = sourceRange.Row
lastRow = sourceRange.Rows.Count
startCol = sourceRange.Column
endCol = sourceRange.Columns.Count - 1
Set loopRange = sourceRange.Parent.Cells(startRow, startCol)
For colCounter = 0 To endCol
targetCounter = 0
For sourceCounter = 0 To lastRow - 1
outString = Trim(loopRange.Offset(sourceCounter, colCounter).Value)
While (Trim(targetRange.Offset(targetCounter, colCounter).Value) <> "")
targetCounter = targetCounter + 1
Wend
targetRange.Offset(targetCounter, colCounter).Value = outString
Next
Next
End Sub
Just the idea of what I was trying to suggest you need to make changes and debug it to suit it to your needs
sub rangeCopy()
Dim p As long
Set targetRange = Workbooks.Open("C:\Users\j\Documents\Workbook2.xltm").Sheets("Quote").Range("A4")
Dim FRow As Long
Dim m As Long
m =Sheets("Input Sheet").Rows.Count
FRow = Sheets("Input Sheet").Range("A" & m).End(xlUp).Row
Set sourceRange = Sheets("Input Sheet").Range("A9:C" &FRow)
sourceRange.Copy
Sheets("Quote").Rows("4:4").Select Selection.Insert Shift:=xlDown
p= FRow + 5
Sheets("Quote").Rows("4:" & p).Copy
Sheets("Quote").Rows("4:4").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End Sub
I have the below code that works great. It parses through all my sheets and finds the row in column A that I want and pastes it to a specified worksheet. However, I need it to copy the specified row plus the next X number of rows. Can someone help me accomplish this?
Sub FindValues()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Integer
For Each ws In Application.ThisWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= LastRow
If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
ws.Rows(i).Copy Sheets("Summary").Range("A2")
i = i - 1
LastRow = LastRow - 1
End If
i = i + 1
Loop
Next
End Sub
You can amend the range of rows being copied on this line like so:
ws.Rows(i & ":" & i + 3).Copy Sheets("Summary").Range("A2")
If the match was found in row 1 for example, the code would render as ws.Rows(1:4).Copy
I have done some minor modifications. Just added (i + number of rows to be copied). Check the below code:
Used Integer copyrw in the code, you can set this integer to copy the number of rows.
Sub FindValues()
Dim ws As Excel.Worksheet
Dim LastRow As Long
Dim i As Integer
Dim copyrw as Integer
copyrw = 3
For Each ws In Application.ThisWorkbook.Worksheets
LastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
i = 1
Do While i <= LastRow
If ws.Range("A" & i).Value = "OwnershipType Ownership Type" Then
ws.Rows(i & ":" & i + copyrw).Copy Sheets("Summary").Range("A2")
i = i - 1
LastRow = LastRow - 1
End If
i = i + 1
Loop
Next
End Sub